update to current master againwip/T13904

516 files changed, 54605 insertions, 39062 deletions

diff --git a/compiler/DEPEND-NOTES b/compiler/DEPEND-NOTES
deleted file mode 100644
index f2ba244315..0000000000
--- a/compiler/DEPEND-NOTES
+++ /dev/null
@@ -1,4 +0,0 @@
-Module dependency information is now given in the GHC commentary
-
-	ghc/docs/comm/genesis/modules.html
-
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs
index 842c0df49d..67905c6067 100644
--- a/compiler/backpack/BkpSyn.hs
+++ b/compiler/backpack/BkpSyn.hs
@@ -17,6 +17,8 @@ module BkpSyn (
     LRenaming, Renaming(..),
     ) where
 
+import GhcPrelude
+
 import HsSyn
 import SrcLoc
 import Outputable
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index 4324e5763b..7784df2ff5 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -18,6 +18,8 @@ module DriverBkp (doBackpack) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 -- In a separate module because it hooks into the parser.
 import BkpSyn
 
diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs
index 6ec243ef20..a1a0b1893b 100644
--- a/compiler/backpack/NameShape.hs
+++ b/compiler/backpack/NameShape.hs
@@ -12,6 +12,8 @@ module NameShape(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Outputable
 import HscTypes
 import Module
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
index 2e738c1ec6..3ae01d72b8 100644
--- a/compiler/backpack/RnModIface.hs
+++ b/compiler/backpack/RnModIface.hs
@@ -15,6 +15,8 @@ module RnModIface(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import SrcLoc
 import Outputable
 import HscTypes
@@ -106,7 +108,6 @@ rnModIface hsc_env insts nsubst iface = do
         deps <- rnDependencies (mi_deps iface)
         -- TODO:
         -- mi_rules
-        -- mi_vect_info (LOW PRIORITY)
         return iface { mi_module = mod
                      , mi_sig_of = sig_of
                      , mi_insts = insts
@@ -422,11 +423,13 @@ rnIfaceDecl d@IfaceData{} = do
             binders <- mapM rnIfaceTyConBinder (ifBinders d)
             ctxt <- mapM rnIfaceType (ifCtxt d)
             cons <- rnIfaceConDecls (ifCons d)
+            res_kind <- rnIfaceType (ifResKind d)
             parent <- rnIfaceTyConParent (ifParent d)
             return d { ifName = name
                      , ifBinders = binders
                      , ifCtxt = ctxt
                      , ifCons = cons
+                     , ifResKind = res_kind
                      , ifParent = parent
                      }
 rnIfaceDecl d@IfaceSynonym{} = do
@@ -509,7 +512,7 @@ rnIfaceTyConParent :: Rename IfaceTyConParent
 rnIfaceTyConParent (IfDataInstance n tc args)
     = IfDataInstance <$> rnIfaceGlobal n
                      <*> rnIfaceTyCon tc
-                     <*> rnIfaceTcArgs args
+                     <*> rnIfaceAppArgs args
 rnIfaceTyConParent IfNoParent = pure IfNoParent
 
 rnIfaceConDecls :: Rename IfaceConDecls
@@ -521,7 +524,8 @@ rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
 rnIfaceConDecl :: Rename IfaceConDecl
 rnIfaceConDecl d = do
     con_name <- rnIfaceGlobal (ifConName d)
-    con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d)
+    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)
+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
     let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
     con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
     con_ctxt <- mapM rnIfaceType (ifConCtxt d)
@@ -531,7 +535,8 @@ rnIfaceConDecl d = do
         rnIfaceBang bang = pure bang
     con_stricts <- mapM rnIfaceBang (ifConStricts d)
     return d { ifConName = con_name
-             , ifConExTvs = con_ex_tvs
+             , ifConExTCvs = con_ex_tvs
+             , ifConUserTvBinders = con_user_tvbs
              , ifConEqSpec = con_eq_spec
              , ifConCtxt = con_ctxt
              , ifConArgTys = con_arg_tys
@@ -552,7 +557,7 @@ rnMaybeDefMethSpec mb = return mb
 rnIfaceAxBranch :: Rename IfaceAxBranch
 rnIfaceAxBranch d = do
     ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
-    lhs <- rnIfaceTcArgs (ifaxbLHS d)
+    lhs <- rnIfaceAppArgs (ifaxbLHS d)
     rhs <- rnIfaceType (ifaxbRHS d)
     return d { ifaxbTyVars = ty_vars
              , ifaxbLHS = lhs
@@ -613,13 +618,13 @@ rnIfaceBndrs = mapM rnIfaceBndr
 
 rnIfaceBndr :: Rename IfaceBndr
 rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
-rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr
+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr
 
 rnIfaceTvBndr :: Rename IfaceTvBndr
 rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
 
 rnIfaceTyConBinder :: Rename IfaceTyConBinder
-rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
 
 rnIfaceAlt :: Rename IfaceAlt
 rnIfaceAlt (conalt, names, rhs)
@@ -636,8 +641,14 @@ rnIfaceLetBndr (IfLetBndr fs ty info jpi)
 rnIfaceLamBndr :: Rename IfaceLamBndr
 rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
 
+rnIfaceMCo :: Rename IfaceMCoercion
+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
+
 rnIfaceCo :: Rename IfaceCoercion
-rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty
+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
+rnIfaceCo (IfaceGReflCo role ty mco)
+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
 rnIfaceCo (IfaceFunCo role co1 co2)
     = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
 rnIfaceCo (IfaceTyConAppCo role tc cos)
@@ -645,8 +656,10 @@ rnIfaceCo (IfaceTyConAppCo role tc cos)
 rnIfaceCo (IfaceAppCo co1 co2)
     = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
 rnIfaceCo (IfaceForAllCo bndr co1 co2)
-    = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
 rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
 rnIfaceCo (IfaceAxiomInstCo n i cs)
     = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
 rnIfaceCo (IfaceUnivCo s r t1 t2)
@@ -663,7 +676,6 @@ rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
 rnIfaceCo (IfaceAxiomRuleCo ax cos)
     = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
 rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
-rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
 
 rnIfaceTyCon :: Rename IfaceTyCon
 rnIfaceTyCon (IfaceTyCon n info)
@@ -681,16 +693,16 @@ rnIfaceType :: Rename IfaceType
 rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
 rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)
 rnIfaceType (IfaceAppTy t1 t2)
-    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2
+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
 rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
 rnIfaceType (IfaceFunTy t1 t2)
     = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
 rnIfaceType (IfaceDFunTy t1 t2)
     = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
 rnIfaceType (IfaceTupleTy s i tks)
-    = IfaceTupleTy s i <$> rnIfaceTcArgs tks
+    = IfaceTupleTy s i <$> rnIfaceAppArgs tks
 rnIfaceType (IfaceTyConApp tc tks)
-    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks
+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
 rnIfaceType (IfaceForAllTy tv t)
     = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
 rnIfaceType (IfaceCoercionTy co)
@@ -699,9 +711,9 @@ rnIfaceType (IfaceCastTy ty co)
     = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
 
 rnIfaceForAllBndr :: Rename IfaceForAllBndr
-rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis
+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
 
-rnIfaceTcArgs :: Rename IfaceTcArgs
-rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts
-rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts
-rnIfaceTcArgs ITC_Nil = pure ITC_Nil
+rnIfaceAppArgs :: Rename IfaceAppArgs
+rnIfaceAppArgs (IA_Invis t ts) = IA_Invis <$> rnIfaceType t <*> rnIfaceAppArgs ts
+rnIfaceAppArgs (IA_Vis t ts) = IA_Vis <$> rnIfaceType t <*> rnIfaceAppArgs ts
+rnIfaceAppArgs IA_Nil = pure IA_Nil
diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs
index ba6db1d9c8..cefa934ab1 100644
--- a/compiler/basicTypes/Avail.hs
+++ b/compiler/basicTypes/Avail.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 --
 -- (c) The University of Glasgow
 --
@@ -15,6 +16,8 @@ module Avail (
     availName, availNames, availNonFldNames,
     availNamesWithSelectors,
     availFlds,
+    availsNamesWithOccs,
+    availNamesWithOccs,
     stableAvailCmp,
     plusAvail,
     trimAvail,
@@ -25,6 +28,8 @@ module Avail (
 
   ) where
 
+import GhcPrelude
+
 import Name
 import NameEnv
 import NameSet
@@ -35,6 +40,7 @@ import ListSetOps
 import Outputable
 import Util
 
+import Data.Data ( Data )
 import Data.List ( find )
 import Data.Function
 
@@ -59,7 +65,7 @@ data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
                                  --     to be in scope, it must be
                                  --     *first* in this list.  Thus,
                                  --     typically: @AvailTC Eq [Eq, ==, \/=]@
-                deriving( Eq )
+                deriving( Eq, Data )
                         -- Equality used when deciding if the
                         -- interface has changed
 
@@ -76,7 +82,7 @@ datatype like
 
 gives rise to the AvailInfo
 
-  AvailTC T [T, MkT] [FieldLabel "foo" False foo],
+  AvailTC T [T, MkT] [FieldLabel "foo" False foo]
 
 whereas if -XDuplicateRecordFields is enabled it gives
 
@@ -94,8 +100,9 @@ multiple distinct fields with the same label. For example,
 
 gives rise to
 
-  AvailTC F [F, MkFInt, MkFBool]
-    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool].
+  AvailTC F [ F, MkFInt, MkFBool ]
+            [ FieldLabel "foo" True $sel:foo:MkFInt
+            , FieldLabel "foo" True $sel:foo:MkFBool ]
 
 Moreover, note that the flIsOverloaded flag need not be the same for
 all the elements of the list.  In the example above, this occurs if
@@ -103,8 +110,9 @@ the two data instances are defined in different modules, one with
 `-XDuplicateRecordFields` enabled and one with it disabled.  Thus it
 is possible to have
 
-  AvailTC F [F, MkFInt, MkFBool]
-    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo].
+  AvailTC F [ F, MkFInt, MkFBool ]
+            [ FieldLabel "foo" True $sel:foo:MkFInt
+            , FieldLabel "foo" False foo ]
 
 If the two data instances are defined in different modules, both
 without `-XDuplicateRecordFields`, it will be impossible to export
@@ -169,6 +177,22 @@ availFlds :: AvailInfo -> [FieldLabel]
 availFlds (AvailTC _ _ fs) = fs
 availFlds _                = []
 
+availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
+availsNamesWithOccs = concatMap availNamesWithOccs
+
+-- | 'Name's made available by the availability information, paired with
+-- the 'OccName' used to refer to each one.
+--
+-- When @DuplicateRecordFields@ is in use, the 'Name' may be the
+-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the
+-- 'OccName' will be the label of the field (e.g. @foo@).
+--
+-- See Note [Representing fields in AvailInfo].
+availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
+availNamesWithOccs (Avail n) = [(n, nameOccName n)]
+availNamesWithOccs (AvailTC _ ns fs)
+  = [ (n, nameOccName n) | n <- ns ] ++
+    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
 
 -- -----------------------------------------------------------------------------
 -- Utility
@@ -225,7 +249,7 @@ filterAvail keep ie rest =
 -- will give Ix(Ix,index,range) and Ix(index)
 -- We want to combine these; addAvail does that
 nubAvails :: [AvailInfo] -> [AvailInfo]
-nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)
+nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)
   where
     add env avail = extendNameEnv_C plusAvail env (availName avail) avail
 
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 90a043de76..151a040393 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -45,14 +45,12 @@ module BasicTypes(
 
         TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
-        DerivStrategy(..),
-
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
         hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
 
         Boxity(..), isBoxed,
 
-        TyPrec(..), maybeParen,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
 
         TupleSort(..), tupleSortBoxity, boxityTupleSort,
         tupleParens,
@@ -83,9 +81,10 @@ module BasicTypes(
 
         Activation(..), isActive, isActiveIn, competesWith,
         isNeverActive, isAlwaysActive, isEarlyActive,
+        activeAfterInitial, activeDuringFinal,
 
         RuleMatchInfo(..), isConLike, isFunLike,
-        InlineSpec(..), isEmptyInlineSpec,
+        InlineSpec(..), noUserInlineSpec,
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
         neverInlinePragma, dfunInlinePragma,
         isDefaultInlinePragma,
@@ -109,6 +108,8 @@ module BasicTypes(
         SpliceExplicitFlag(..)
    ) where
 
+import GhcPrelude
+
 import FastString
 import Outputable
 import SrcLoc ( Located,unLoc )
@@ -440,7 +441,7 @@ compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
 -- |Captures the fixity of declarations as they are parsed. This is not
 -- necessarily the same as the fixity declaration, as the normal fixity may be
 -- overridden using parens or backticks.
-data LexicalFixity = Prefix | Infix deriving (Typeable,Data,Eq)
+data LexicalFixity = Prefix | Infix deriving (Data,Eq)
 
 instance Outputable LexicalFixity where
   ppr Prefix = text "Prefix"
@@ -543,31 +544,6 @@ instance Outputable Origin where
 {-
 ************************************************************************
 *                                                                      *
-                Deriving strategies
-*                                                                      *
-************************************************************************
--}
-
--- | Which technique the user explicitly requested when deriving an instance.
-data DerivStrategy
-  -- See Note [Deriving strategies] in TcDeriv
-  = StockStrategy    -- ^ GHC's \"standard\" strategy, which is to implement a
-                     --   custom instance for the data type. This only works
-                     --   for certain types that GHC knows about (e.g., 'Eq',
-                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
-                     --   etc.)
-  | AnyclassStrategy -- ^ @-XDeriveAnyClass@
-  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@
-  deriving (Eq, Data)
-
-instance Outputable DerivStrategy where
-    ppr StockStrategy    = text "stock"
-    ppr AnyclassStrategy = text "anyclass"
-    ppr NewtypeStrategy  = text "newtype"
-
-{-
-************************************************************************
-*                                                                      *
                 Instance overlap flag
 *                                                                      *
 ************************************************************************
@@ -690,40 +666,25 @@ pprSafeOverlap False = empty
 {-
 ************************************************************************
 *                                                                      *
-                Type precedence
+                Precedence
 *                                                                      *
 ************************************************************************
 -}
 
-data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
-  = TopPrec         -- No parens
-  | FunPrec         -- Function args; no parens for tycon apps
-  | TyOpPrec        -- Infix operator
-  | TyConPrec       -- Tycon args; no parens for atomic
-
-instance Eq TyPrec where
-  (==) a b = case compare a b of
-               EQ -> True
-               _  -> False
-
-instance Ord TyPrec where
-  compare TopPrec TopPrec  = EQ
-  compare TopPrec _        = LT
-
-  compare FunPrec TopPrec   = GT
-  compare FunPrec FunPrec   = EQ
-  compare FunPrec TyOpPrec  = EQ   -- See Note [Type operator precedence]
-  compare FunPrec TyConPrec = LT
+-- | A general-purpose pretty-printing precedence type.
+newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
+-- See Note [Precedence in types]
 
-  compare TyOpPrec TopPrec   = GT
-  compare TyOpPrec FunPrec   = EQ  -- See Note [Type operator precedence]
-  compare TyOpPrec TyOpPrec  = EQ
-  compare TyOpPrec TyConPrec = LT
+topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec
+topPrec = PprPrec 0 -- No parens
+sigPrec = PprPrec 1 -- Explicit type signatures
+funPrec = PprPrec 2 -- Function args; no parens for constructor apps
+                    -- See [Type operator precedence] for why both
+                    -- funPrec and opPrec exist.
+opPrec  = PprPrec 2 -- Infix operator
+appPrec = PprPrec 3 -- Constructor args; no parens for atomic
 
-  compare TyConPrec TyConPrec = EQ
-  compare TyConPrec _         = GT
-
-maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc
+maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
 maybeParen ctxt_prec inner_prec pretty
   | ctxt_prec < inner_prec = pretty
   | otherwise              = parens pretty
@@ -731,12 +692,12 @@ maybeParen ctxt_prec inner_prec pretty
 {- Note [Precedence in types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Many pretty-printing functions have type
-    ppr_ty :: TyPrec -> Type -> SDoc
+    ppr_ty :: PprPrec -> Type -> SDoc
 
-The TyPrec gives the binding strength of the context.  For example, in
+The PprPrec gives the binding strength of the context.  For example, in
    T ty1 ty2
 we will pretty-print 'ty1' and 'ty2' with the call
-  (ppr_ty TyConPrec ty)
+  (ppr_ty appPrec ty)
 to indicate that the context is that of an argument of a TyConApp.
 
 We use this consistently for Type and HsType.
@@ -749,16 +710,16 @@ pretty printer follows the following precedence order:
    TyConPrec         Type constructor application
    TyOpPrec/FunPrec  Operator application and function arrow
 
-We have FunPrec and TyOpPrec to represent the precedence of function
+We have funPrec and opPrec to represent the precedence of function
 arrow and type operators respectively, but currently we implement
-FunPred == TyOpPrec, so that we don't distinguish the two. Reason:
+funPrec == opPrec, so that we don't distinguish the two. Reason:
 it's hard to parse a type like
     a ~ b => c * d -> e - f
 
-By treating TyOpPrec = FunPrec we end up with more parens
+By treating opPrec = funPrec we end up with more parens
     (a ~ b) => (c * d) -> (e - f)
 
-But the two are different constructors of TyPrec so we could make
+But the two are different constructors of PprPrec so we could make
 (->) bind more or less tightly if we wanted.
 -}
 
@@ -789,9 +750,8 @@ tupleParens :: TupleSort -> SDoc -> SDoc
 tupleParens BoxedTuple      p = parens p
 tupleParens UnboxedTuple    p = text "(#" <+> p <+> ptext (sLit "#)")
 tupleParens ConstraintTuple p   -- In debug-style write (% Eq a, Ord b %)
-  = sdocWithPprDebug $ \dbg -> if dbg
-      then text "(%" <+> p <+> ptext (sLit "%)")
-      else parens p
+  = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)"))
+               (parens p)
 
 {-
 ************************************************************************
@@ -1183,6 +1143,15 @@ instance Outputable CompilerPhase where
    ppr (Phase n)    = int n
    ppr InitialPhase = text "InitialPhase"
 
+activeAfterInitial :: Activation
+-- Active in the first phase after the initial phase
+-- Currently we have just phases [2,1,0]
+activeAfterInitial = ActiveAfter NoSourceText 2
+
+activeDuringFinal :: Activation
+-- Active in the final simplification phase (which is repeated)
+activeDuringFinal = ActiveAfter NoSourceText 0
+
 -- See note [Pragma source text]
 data Activation = NeverActive
                 | AlwaysActive
@@ -1219,11 +1188,11 @@ data InlinePragma            -- Note [InlinePragma]
 
 -- | Inline Specification
 data InlineSpec   -- What the user's INLINE pragma looked like
-  = Inline
-  | Inlinable
-  | NoInline
-  | EmptyInlineSpec  -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,
-                     -- where there isn't any real inline pragma at all
+  = Inline       -- User wrote INLINE
+  | Inlinable    -- User wrote INLINABLE
+  | NoInline     -- User wrote NOINLINE
+  | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE
+                 -- e.g. in `defaultInlinePragma` or when created by CSE
   deriving( Eq, Data, Show )
         -- Show needed for Lexer.x
 
@@ -1233,7 +1202,7 @@ This data type mirrors what you can write in an INLINE or NOINLINE pragma in
 the source program.
 
 If you write nothing at all, you get defaultInlinePragma:
-   inl_inline = EmptyInlineSpec
+   inl_inline = NoUserInline
    inl_act    = AlwaysActive
    inl_rule   = FunLike
 
@@ -1306,16 +1275,16 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _       = False
 
-isEmptyInlineSpec :: InlineSpec -> Bool
-isEmptyInlineSpec EmptyInlineSpec = True
-isEmptyInlineSpec _               = False
+noUserInlineSpec :: InlineSpec -> Bool
+noUserInlineSpec NoUserInline = True
+noUserInlineSpec _            = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
                                    , inl_act = AlwaysActive
                                    , inl_rule = FunLike
-                                   , inl_inline = EmptyInlineSpec
+                                   , inl_inline = NoUserInline
                                    , inl_sat = Nothing }
 
 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
@@ -1335,7 +1304,7 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
+  = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
 isInlinePragma prag = case inl_inline prag of
@@ -1380,10 +1349,10 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = text "FUNLIKE"
 
 instance Outputable InlineSpec where
-   ppr Inline          = text "INLINE"
-   ppr NoInline        = text "NOINLINE"
-   ppr Inlinable       = text "INLINABLE"
-   ppr EmptyInlineSpec = empty
+   ppr Inline       = text "INLINE"
+   ppr NoInline     = text "NOINLINE"
+   ppr Inlinable    = text "INLINABLE"
+   ppr NoUserInline = text "NOUSERINLINE" -- what is better?
 
 instance Outputable InlinePragma where
   ppr = pprInline
@@ -1394,7 +1363,9 @@ pprInline = pprInline' True
 pprInlineDebug :: InlinePragma -> SDoc
 pprInlineDebug = pprInline' False
 
-pprInline' :: Bool -> InlinePragma -> SDoc
+pprInline' :: Bool           -- True <=> do not display the inl_inline field
+           -> InlinePragma
+           -> SDoc
 pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
                                     , inl_rule = info, inl_sat = mb_arity })
     = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
@@ -1475,9 +1446,12 @@ data IntegralLit
   deriving (Data, Show)
 
 mkIntegralLit :: Integral a => a -> IntegralLit
-mkIntegralLit i = IL { il_text = SourceText (show (fromIntegral i :: Int))
+mkIntegralLit i = IL { il_text = SourceText (show i_integer)
                      , il_neg = i < 0
-                     , il_value = toInteger i }
+                     , il_value = i_integer }
+  where
+    i_integer :: Integer
+    i_integer = toInteger i
 
 negateIntegralLit :: IntegralLit -> IntegralLit
 negateIntegralLit (IL text neg value)
@@ -1502,6 +1476,13 @@ data FractionalLit
 
 mkFractionalLit :: Real a => a -> FractionalLit
 mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
+                           -- Converting to a Double here may technically lose
+                           -- precision (see #15502). We could alternatively
+                           -- convert to a Rational for the most accuracy, but
+                           -- it would cause Floats and Doubles to be displayed
+                           -- strangely, so we opt not to do this. (In contrast
+                           -- to mkIntegralLit, where we always convert to an
+                           -- Integer for the highest accuracy.)
                        , fl_neg = r < 0
                        , fl_value = toRational r }
 
diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs
index aa6a362f68..a9d7548b8a 100644
--- a/compiler/basicTypes/ConLike.hs
+++ b/compiler/basicTypes/ConLike.hs
@@ -12,7 +12,7 @@ module ConLike (
         , conLikeArity
         , conLikeFieldLabels
         , conLikeInstOrigArgTys
-        , conLikeExTyVars
+        , conLikeExTyCoVars
         , conLikeName
         , conLikeStupidTheta
         , conLikeWrapId_maybe
@@ -26,6 +26,8 @@ module ConLike (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DataCon
 import PatSyn
 import Outputable
@@ -111,10 +113,10 @@ conLikeInstOrigArgTys (RealDataCon data_con) tys =
 conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
     patSynInstArgTys pat_syn tys
 
--- | Existentially quantified type variables
-conLikeExTyVars :: ConLike -> [TyVar]
-conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1
-conLikeExTyVars (PatSynCon psyn1)   = patSynExTyVars psyn1
+-- | Existentially quantified type/coercion variables
+conLikeExTyCoVars :: ConLike -> [TyCoVar]
+conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
+conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1
 
 conLikeName :: ConLike -> Name
 conLikeName (RealDataCon data_con) = dataConName data_con
@@ -150,7 +152,7 @@ conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys
 --
 -- 1) The universally quantified type variables
 --
--- 2) The existentially quantified type variables
+-- 2) The existentially quantified type/coercion variables
 --
 -- 3) The equality specification
 --
@@ -163,7 +165,9 @@ conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys
 --
 -- 7) The original result type
 conLikeFullSig :: ConLike
-               -> ([TyVar], [TyVar], [EqSpec]
+               -> ([TyVar], [TyCoVar], [EqSpec]
+                   -- Why tyvars for universal but tycovars for existential?
+                   -- See Note [Existential coercion variables] in DataCon
                   , ThetaType, ThetaType, [Type], Type)
 conLikeFullSig (RealDataCon con) =
   let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 73bbf2cf57..b7435e5b54 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -31,9 +31,8 @@ module DataCon (
         dataConName, dataConIdentity, dataConTag, dataConTagZ,
         dataConTyCon, dataConOrigTyCon,
         dataConUserType,
-        dataConUnivTyVars, dataConUnivTyVarBinders,
-        dataConExTyVars, dataConExTyVarBinders,
-        dataConAllTyVars,
+        dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,
+        dataConUserTyVars, dataConUserTyVarBinders,
         dataConEqSpec, dataConTheta,
         dataConStupidTheta,
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
@@ -52,8 +51,9 @@ module DataCon (
         isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
         isUnboxedSumCon,
         isVanillaDataCon, classDataCon, dataConCannotMatch,
+        dataConUserTyVarsArePermuted,
         isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
-        specialPromotedDc, isLegacyPromotableDataCon, isLegacyPromotableTyCon,
+        specialPromotedDc,
 
         -- ** Promotion related functions
         promoteDataCon
@@ -61,6 +61,8 @@ module DataCon (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
 import ForeignCall ( CType )
@@ -73,7 +75,6 @@ import Name
 import PrelNames
 import Var
 import Outputable
-import ListSetOps
 import Util
 import BasicTypes
 import FastString
@@ -85,7 +86,7 @@ import Unique( mkAlphaTyVarUnique )
 import qualified Data.Data as Data
 import Data.Char
 import Data.Word
-import Data.List( mapAccumL, find )
+import Data.List( find )
 
 {-
 Data constructor representation
@@ -275,33 +276,43 @@ data DataCon
         -- Running example:
         --
         --      *** As declared by the user
-        --  data T a where
-        --    MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y)
+        --  data T a b c where
+        --    MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c
 
         --      *** As represented internally
-        --  data T a where
-        --    MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a
+        --  data T a b c where
+        --    MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x)
+        --        => x -> y -> T a b c
         --
         -- The next six fields express the type of the constructor, in pieces
         -- e.g.
         --
-        --      dcUnivTyVars  = [a]
-        --      dcExTyVars    = [x,y]
-        --      dcEqSpec      = [a~(x,y)]
-        --      dcOtherTheta  = [x~y, Ord x]
-        --      dcOrigArgTys  = [x,y]
-        --      dcRepTyCon       = T
-
-        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
-        -- FOR THE PARENT TyCon. (This is a change (Oct05): previously, vanilla
-        -- datacons guaranteed to have the same type variables as their parent TyCon,
-        -- but that seems ugly.)
+        --      dcUnivTyVars       = [a,b,c]
+        --      dcExTyCoVars       = [x,y]
+        --      dcUserTyVarBinders = [c,y,x,b]
+        --      dcEqSpec           = [a~(x,y)]
+        --      dcOtherTheta       = [x~y, Ord x]
+        --      dcOrigArgTys       = [x,y]
+        --      dcRepTyCon         = T
+
+        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE
+        -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously,
+        -- vanilla datacons guaranteed to have the same type variables as their
+        -- parent TyCon, but that seems ugly.) They can be different in the case
+        -- where a GADT constructor uses different names for the universal
+        -- tyvars than does the tycon. For example:
+        --
+        --   data H a where
+        --     MkH :: b -> H b
+        --
+        -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH
+        -- will be [b].
 
         dcVanilla :: Bool,      -- True <=> This is a vanilla Haskell 98 data constructor
                                 --          Its type is of form
                                 --              forall a1..an . t1 -> ... tm -> T a1..an
                                 --          No existentials, no coercions, nothing.
-                                -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
+                                -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = []
                 -- NB 1: newtypes always have a vanilla data con
                 -- NB 2: a vanilla constructor can still be declared in GADT-style
                 --       syntax, provided its type looks like the above.
@@ -310,16 +321,30 @@ data DataCon
         -- Universally-quantified type vars [a,b,c]
         -- INVARIANT: length matches arity of the dcRepTyCon
         -- INVARIANT: result type of data con worker is exactly (T a b c)
-        dcUnivTyVars    :: [TyVarBinder],
+        -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with
+        --            the tyConTyVars of the parent TyCon
+        dcUnivTyVars     :: [TyVar],
 
-        -- Existentially-quantified type vars [x,y]
-        dcExTyVars     :: [TyVarBinder],
+        -- Existentially-quantified type and coercion vars [x,y]
+        -- For an example involving coercion variables,
+        -- Why tycovars? See Note [Existential coercion variables]
+        dcExTyCoVars     :: [TyCoVar],
 
-        -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames
+        -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames
         -- Reason: less confusing, and easier to generate IfaceSyn
 
+        -- The type/coercion vars in the order the user wrote them [c,y,x,b]
+        -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set
+        --            of tyvars (*not* covars) of dcExTyCoVars unioned with the
+        --            set of dcUnivTyVars whose tyvars do not appear in dcEqSpec
+        -- See Note [DataCon user type variable binders]
+        dcUserTyVarBinders :: [TyVarBinder],
+
         dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,
-                                -- _as written by the programmer_
+                                -- _as written by the programmer_.
+                                -- Only non-dependent GADT equalities (dependent
+                                -- GADT equalities are in the covars of
+                                -- dcExTyCoVars).
 
                 -- This field allows us to move conveniently between the two ways
                 -- of representing a GADT constructor's type:
@@ -383,7 +408,7 @@ data DataCon
         dcRep      :: DataConRep,
 
         -- Cached; see Note [DataCon arities]
-        -- INVARIANT: dcRepArity    == length dataConRepArgTys
+        -- INVARIANT: dcRepArity    == length dataConRepArgTys + count isCoVar (dcExTyCoVars)
         -- INVARIANT: dcSourceArity == length dcOrigArgTys
         dcRepArity    :: Arity,
         dcSourceArity :: Arity,
@@ -421,13 +446,36 @@ For the TyVarBinders in a DataCon and PatSyn:
 
  * Each argument flag is Inferred or Specified.
    None are Required. (A DataCon is a term-level function; see
-   Note [No Required TyBinder in terms] in TyCoRep.)
+   Note [No Required TyCoBinder in terms] in TyCoRep.)
 
 Why do we need the TyVarBinders, rather than just the TyVars?  So that
 we can construct the right type for the DataCon with its foralls
 attributed the correct visibility.  That in turn governs whether you
 can use visible type application at a call of the data constructor.
 
+See also [DataCon user type variable binders] for an extended discussion on the
+order in which TyVarBinders appear in a DataCon.
+
+Note [Existential coercion variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For now (Aug 2018) we can't write coercion quantifications in source Haskell, but
+we can in Core. Consider having:
+
+  data T :: forall k. k -> k -> Constraint where
+    MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co))
+        => T k a b
+
+  dcUnivTyVars       = [k,a,b]
+  dcExTyCoVars       = [k',c,co]
+  dcUserTyVarBinders = [k,a,k',c]
+  dcEqSpec           = [b~(c|>co)]
+  dcOtherTheta       = []
+  dcOrigArgTys       = []
+  dcRepTyCon         = T
+
+  Function call 'dataConKindEqSpec' returns [k'~k]
+
 Note [DataCon arities]
 ~~~~~~~~~~~~~~~~~~~~~~
 dcSourceArity does not take constraints into account,
@@ -435,6 +483,85 @@ but dcRepArity does.  For example:
    MkT :: Ord a => a -> T a
     dcSourceArity = 1
     dcRepArity    = 2
+
+Note [DataCon user type variable binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In System FC, data constructor type signatures always quantify over all of
+their universal type variables, followed by their existential type variables.
+Normally, this isn't a problem, as most datatypes naturally quantify their type
+variables in this order anyway. For example:
+
+  data T a b = forall c. MkT b c
+
+Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`,
+where k, a, and b are universal and c is existential. (The inferred variable k
+isn't available for TypeApplications, hence why it's in braces.) This is a
+perfectly reasonable order to use, as the syntax of H98-style datatypes
+(+ ExistentialQuantification) suggests it.
+
+Things become more complicated when GADT syntax enters the picture. Consider
+this example:
+
+  data X a where
+    MkX :: forall b a. b -> Proxy a -> X a
+
+If we adopt the earlier approach of quantifying all the universal variables
+followed by all the existential ones, GHC would come up with this type
+signature for MkX:
+
+  MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a
+
+But this is not what we want at all! After all, if a user were to use
+TypeApplications on MkX, they would expect to instantiate `b` before `a`,
+as that's the order in which they were written in the `forall`. (See #11721.)
+Instead, we'd like GHC to come up with this type signature:
+
+  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a
+
+In fact, even if we left off the explicit forall:
+
+  data X a where
+    MkX :: b -> Proxy a -> X a
+
+Then a user should still expect `b` to be quantified before `a`, since
+according to the rules of TypeApplications, in the absence of `forall` GHC
+performs a stable topological sort on the type variables in the user-written
+type signature, which would place `b` before `a`.
+
+But as noted above, enacting this behavior is not entirely trivial, as System
+FC demands the variables go in universal-then-existential order under the hood.
+Our solution is thus to equip DataCon with two different sets of type
+variables:
+
+* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential
+  type/coercion variables, respectively. Their order is irrelevant for the
+  purposes of TypeApplications, and as a consequence, they do not come equipped
+  with visibilities (that is, they are TyVars/TyCoVars instead of
+  TyCoVarBinders).
+* dcUserTyVarBinders, for the type variables binders in the order in which they
+  originally arose in the user-written type signature. Their order *does* matter
+  for TypeApplications, so they are full TyVarBinders, complete with
+  visibilities.
+
+This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders
+consists precisely of:
+
+* The set of tyvars in dcUnivTyVars whose type variables do not appear in
+  dcEqSpec, unioned with:
+* The set of tyvars (*not* covars) in dcExTyCoVars
+  No covars here because because they're not user-written
+
+The word "set" is used above because the order in which the tyvars appear in
+dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or
+dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of
+(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the
+ordering, they in fact share the same type variables (with the same Uniques). We
+sometimes refer to this as "the dcUserTyVarBinders invariant".
+
+dcUserTyVarBinders, as the name suggests, is the one that users will see most of
+the time. It's used when computing the type signature of a data constructor (see
+dataConUserType), and as a result, it's what matters from a TypeApplications
+perspective.
 -}
 
 -- | Data Constructor Representation
@@ -540,7 +667,7 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict
 data EqSpec = EqSpec TyVar
                      Type
 
--- | Make an 'EqSpec'
+-- | Make a non-dependent 'EqSpec'
 mkEqSpec :: TyVar -> Type -> EqSpec
 mkEqSpec tv ty = EqSpec tv ty
 
@@ -566,13 +693,12 @@ substEqSpec subst (EqSpec tv ty)
   where
     tv' = getTyVar "substEqSpec" (substTyVar subst tv)
 
--- | Filter out any TyBinders mentioned in an EqSpec
-filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]
+-- | Filter out any 'TyVar's mentioned in an 'EqSpec'.
+filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]
 filterEqSpec eq_spec
   = filter not_in_eq_spec
   where
-    not_in_eq_spec bndr = let var = binderVar bndr in
-                          all (not . (== var) . eqSpecTyVar) eq_spec
+    not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec
 
 instance Outputable EqSpec where
   ppr (EqSpec tv ty) = ppr (tv, ty)
@@ -750,44 +876,49 @@ mkDataCon :: Name
           -> [HsSrcBang]    -- ^ Strictness/unpack annotations, from user
           -> [FieldLabel]   -- ^ Field labels for the constructor,
                             -- if it is a record, otherwise empty
-          -> [TyVarBinder]  -- ^ Universals. See Note [TyVarBinders in DataCons]
-          -> [TyVarBinder]  -- ^ Existentials.
-                            -- (These last two must be Named and Inferred/Specified)
+          -> [TyVar]        -- ^ Universals.
+          -> [TyCoVar]      -- ^ Existentials.
+          -> [TyVarBinder]  -- ^ User-written 'TyVarBinder's.
+                            --   These must be Inferred/Specified.
+                            --   See @Note [TyVarBinders in DataCons]@
           -> [EqSpec]       -- ^ GADT equalities
-          -> ThetaType      -- ^ Theta-type occuring before the arguments proper
-          -> [Type]         -- ^ Original argument types
-          -> Type           -- ^ Original result type
-          -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
-          -> TyCon          -- ^ Representation type constructor
-          -> ThetaType      -- ^ The "stupid theta", context of the data
-                            -- declaration e.g. @data Eq a => T a ...@
-          -> Id             -- ^ Worker Id
-          -> DataConRep     -- ^ Representation
+          -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper
+          -> [KnotTied Type]    -- ^ Original argument types
+          -> KnotTied Type      -- ^ Original result type
+          -> RuntimeRepInfo     -- ^ See comments on 'TyCon.RuntimeRepInfo'
+          -> KnotTied TyCon     -- ^ Representation type constructor
+          -> ConTag             -- ^ Constructor tag
+          -> ThetaType          -- ^ The "stupid theta", context of the data
+                                -- declaration e.g. @data Eq a => T a ...@
+          -> Id                 -- ^ Worker Id
+          -> DataConRep         -- ^ Representation
           -> DataCon
   -- Can get the tag from the TyCon
 
 mkDataCon name declared_infix prom_info
           arg_stricts   -- Must match orig_arg_tys 1-1
           fields
-          univ_tvs ex_tvs
+          univ_tvs ex_tvs user_tvbs
           eq_spec theta
-          orig_arg_tys orig_res_ty rep_info rep_tycon
+          orig_arg_tys orig_res_ty rep_info rep_tycon tag
           stupid_theta work_id rep
--- Warning: mkDataCon is not a good place to check invariants.
+-- Warning: mkDataCon is not a good place to check certain invariants.
 -- If the programmer writes the wrong result type in the decl, thus:
 --      data T a where { MkT :: S }
 -- then it's possible that the univ_tvs may hit an assertion failure
 -- if you pull on univ_tvs.  This case is checked by checkValidDataCon,
--- so the error is detected properly... it's just that asaertions here
+-- so the error is detected properly... it's just that assertions here
 -- are a little dodgy.
 
   = con
   where
     is_vanilla = null ex_tvs && null eq_spec && null theta
+
     con = MkData {dcName = name, dcUnique = nameUnique name,
                   dcVanilla = is_vanilla, dcInfix = declared_infix,
                   dcUnivTyVars = univ_tvs,
-                  dcExTyVars = ex_tvs,
+                  dcExTyCoVars = ex_tvs,
+                  dcUserTyVarBinders = user_tvbs,
                   dcEqSpec = eq_spec,
                   dcOtherTheta = theta,
                   dcStupidTheta = stupid_theta,
@@ -798,23 +929,29 @@ mkDataCon name declared_infix prom_info
                   dcWorkId = work_id,
                   dcRep = rep,
                   dcSourceArity = length orig_arg_tys,
-                  dcRepArity = length rep_arg_tys,
+                  dcRepArity = length rep_arg_tys + count isCoVar ex_tvs,
                   dcPromoted = promoted }
 
         -- The 'arg_stricts' passed to mkDataCon are simply those for the
         -- source-language arguments.  We add extra ones for the
         -- dictionary arguments right here.
 
-    tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
     rep_arg_tys = dataConRepArgTys con
 
-    rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
-             mkFunTys rep_arg_tys $
-             mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs))
+    rep_ty =
+      case rep of
+        -- If the DataCon has no wrapper, then the worker's type *is* the
+        -- user-facing type, so we can simply use dataConUserType.
+        NoDataConRep -> dataConUserType con
+        -- If the DataCon has a wrapper, then the worker's type is never seen
+        -- by the user. The visibilities we pick do not matter here.
+        DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
+                 mkFunTys rep_arg_tys $
+                 mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
       -- See Note [Promoted data constructors] in TyCon
     prom_tv_bndrs = [ mkNamedTyConBinder vis tv
-                    | TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ]
+                    | Bndr tv vis <- user_tvbs ]
 
     prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)
     prom_res_kind  = orig_res_ty
@@ -822,8 +959,9 @@ mkDataCon name declared_infix prom_info
                                        (prom_tv_bndrs ++ prom_arg_bndrs)
                                        prom_res_kind roles rep_info
 
-    roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
-            map (const Representational) orig_arg_tys
+    roles = map (\tv -> if isTyVar tv then Nominal else Phantom)
+                (univ_tvs ++ ex_tvs)
+            ++ map (const Representational) orig_arg_tys
 
 mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]
 -- Make sure that the "anonymous" tyvars don't clash in
@@ -888,31 +1026,36 @@ dataConIsInfix = dcInfix
 
 -- | The universally-quantified type variables of the constructor
 dataConUnivTyVars :: DataCon -> [TyVar]
-dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs
+dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs
 
--- | 'TyBinder's for the universally-quantified type variables
-dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]
-dataConUnivTyVarBinders = dcUnivTyVars
+-- | The existentially-quantified type/coercion variables of the constructor
+-- including dependent (kind-) GADT equalities
+dataConExTyCoVars :: DataCon -> [TyCoVar]
+dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs
 
--- | The existentially-quantified type variables of the constructor
-dataConExTyVars :: DataCon -> [TyVar]
-dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs
+-- | Both the universal and existential type/coercion variables of the constructor
+dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar]
+dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })
+  = univ_tvs ++ ex_tvs
 
--- | 'TyBinder's for the existentially-quantified type variables
-dataConExTyVarBinders :: DataCon -> [TyVarBinder]
-dataConExTyVarBinders = dcExTyVars
+-- See Note [DataCon user type variable binders]
+-- | The type variables of the constructor, in the order the user wrote them
+dataConUserTyVars :: DataCon -> [TyVar]
+dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs
 
--- | Both the universal and existentiatial type variables of the constructor
-dataConAllTyVars :: DataCon -> [TyVar]
-dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
-  = binderVars (univ_tvs ++ ex_tvs)
+-- See Note [DataCon user type variable binders]
+-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the
+-- user wrote them
+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
+dataConUserTyVarBinders = dcUserTyVarBinders
 
 -- | Equalities derived from the result type of the data constructor, as written
 -- by the programmer in any GADT declaration. This includes *all* GADT-like
 -- equalities, including those written in by hand by the programmer.
 dataConEqSpec :: DataCon -> [EqSpec]
-dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
-  = eq_spec ++
+dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
+  = dataConKindEqSpec con
+    ++ eq_spec ++
     [ spec   -- heterogeneous equality
     | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta
     , tc `hasKey` heqTyConKey
@@ -930,11 +1073,29 @@ dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
                     _             -> []
     ]
 
+-- | Dependent (kind-level) equalities in a constructor.
+-- There are extracted from the existential variables.
+-- See Note [Existential coercion variables]
+dataConKindEqSpec :: DataCon -> [EqSpec]
+dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs})
+  -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future),
+  -- which are frequently used functions.
+  -- For now (Aug 2018) this function always return empty set as we don't really
+  -- have coercion variables.
+  -- In the future when we do, we might want to cache this information in DataCon
+  -- so it won't be computed every time when aforementioned functions are called.
+  = [ EqSpec tv ty
+    | cv <- ex_tcvs
+    , isCoVar cv
+    , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv
+          tv = getTyVar "dataConKindEqSpec" ty1
+    ]
 
--- | The *full* constraints on the constructor type.
+-- | The *full* constraints on the constructor type, including dependent GADT
+-- equalities.
 dataConTheta :: DataCon -> ThetaType
-dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
-  = eqSpecPreds eq_spec ++ theta
+dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
+  = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta
 
 -- | Get the Id of the 'DataCon' worker: a function that is the "actual"
 -- constructor and has no top level binding in the program. The type may
@@ -944,9 +1105,11 @@ dataConWorkId :: DataCon -> Id
 dataConWorkId dc = dcWorkId dc
 
 -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"
--- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.
--- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor
--- and also for a newtype (whose constructor is inlined compulsorily)
+-- constructor so it has the type visible in the source program: c.f.
+-- 'dataConWorkId'.
+-- Returns Nothing if there is no wrapper, which occurs for an algebraic data
+-- constructor and also for a newtype (whose constructor is inlined
+-- compulsorily)
 dataConWrapId_maybe :: DataCon -> Maybe Id
 dataConWrapId_maybe dc = case dcRep dc of
                            NoDataConRep -> Nothing
@@ -1035,58 +1198,65 @@ dataConBoxer _ = Nothing
 
 -- | The \"signature\" of the 'DataCon' returns, in order:
 --
--- 1) The result of 'dataConAllTyVars',
+-- 1) The result of 'dataConUnivAndExTyCoVars',
 --
--- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit
---    parameter - whatever)
+-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary,
+--    implicit parameter - whatever), including dependent GADT equalities.
+--    Dependent GADT equalities are *also* listed in return value (1), so be
+--    careful!
 --
 -- 3) The type arguments to the constructor
 --
 -- 4) The /original/ result type of the 'DataCon'
-dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
+dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)
 dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (dataConAllTyVars con, dataConTheta con, arg_tys, res_ty)
+  = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty)
 
 dataConInstSig
   :: DataCon
   -> [Type]    -- Instantiate the *universal* tyvars with these types
-  -> ([TyVar], ThetaType, [Type])  -- Return instantiated existentials
-                                   -- theta and arg tys
+  -> ([TyCoVar], ThetaType, [Type])  -- Return instantiated existentials
+                                     -- theta and arg tys
 -- ^ Instantiate the universal tyvars of a data con,
---   returning the instantiated existentials, constraints, and args
-dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs
-                       , dcEqSpec = eq_spec, dcOtherTheta  = theta
-                       , dcOrigArgTys = arg_tys })
+--   returning
+--     ( instantiated existentials
+--     , instantiated constraints including dependent GADT equalities
+--         which are *also* listed in the instantiated existentials
+--     , instantiated args)
+dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs
+                           , dcOrigArgTys = arg_tys })
                univ_tys
   = ( ex_tvs'
-    , substTheta subst (eqSpecPreds eq_spec ++ theta)
+    , substTheta subst (dataConTheta con)
     , substTys   subst arg_tys)
   where
-    univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys
-    (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $
-                       binderVars ex_tvs
+    univ_subst = zipTvSubst univ_tvs univ_tys
+    (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs
 
 
 -- | The \"full signature\" of the 'DataCon' returns, in order:
 --
 -- 1) The result of 'dataConUnivTyVars'
 --
--- 2) The result of 'dataConExTyVars'
+-- 2) The result of 'dataConExTyCoVars'
 --
--- 3) The GADT equalities
+-- 3) The non-dependent GADT equalities.
+--    Dependent GADT equalities are implied by coercion variables in
+--    return value (2).
 --
--- 4) The result of 'dataConDictTheta'
+-- 4) The other constraints of the data constructor type, excluding GADT
+-- equalities
 --
 -- 5) The original argument types to the 'DataCon' (i.e. before
 --    any change of the representation of the type)
 --
 -- 6) The original result type of the 'DataCon'
 dataConFullSig :: DataCon
-               -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type)
-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs,
                         dcEqSpec = eq_spec, dcOtherTheta = theta,
                         dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty)
+  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
 
 dataConOrigResTy :: DataCon -> Type
 dataConOrigResTy dc = dcOrigResTy dc
@@ -1107,19 +1277,21 @@ dataConUserType :: DataCon -> Type
 --
 -- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c
 --
+-- The type variables are quantified in the order that the user wrote them.
+-- See @Note [DataCon user type variable binders]@.
+--
 -- NB: If the constructor is part of a data instance, the result type
 -- mentions the family tycon, not the internal one.
-dataConUserType (MkData { dcUnivTyVars = univ_tvs,
-                          dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
+dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,
                           dcOtherTheta = theta, dcOrigArgTys = arg_tys,
                           dcOrigResTy = res_ty })
-  = mkForAllTys (filterEqSpec eq_spec univ_tvs) $
-    mkForAllTys ex_tvs $
+  = mkForAllTys user_tvbs $
     mkFunTys theta $
     mkFunTys arg_tys $
     res_ty
 
--- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation
+-- | Finds the instantiated types of the arguments required to construct a
+-- 'DataCon' representation
 -- NB: these INCLUDE any dictionary args
 --     but EXCLUDE the data-declaration context, which is discarded
 -- It's all post-flattening etc; this is a representation type
@@ -1129,11 +1301,11 @@ dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality
                   -> [Type]     -- ^ Instantiated at these types
                   -> [Type]
 dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
-                              dcExTyVars = ex_tvs}) inst_tys
+                              dcExTyCoVars = ex_tvs}) inst_tys
  = ASSERT2( univ_tvs `equalLength` inst_tys
           , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
    ASSERT2( null ex_tvs, ppr dc )
-   map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc)
+   map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
 
 -- | Returns just the instantiated /value/ argument types of a 'DataCon',
 -- (excluding dictionary args)
@@ -1146,19 +1318,20 @@ dataConInstOrigArgTys
 -- But for the call in MatchCon, we really do want just the value args
 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
                                   dcUnivTyVars = univ_tvs,
-                                  dcExTyVars = ex_tvs}) inst_tys
+                                  dcExTyCoVars = ex_tvs}) inst_tys
   = ASSERT2( tyvars `equalLength` inst_tys
-          , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
-    map (substTyWith tyvars inst_tys) arg_tys
+           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
+    map (substTy subst) arg_tys
   where
-    tyvars = binderVars (univ_tvs ++ ex_tvs)
+    tyvars = univ_tvs ++ ex_tvs
+    subst  = zipTCvSubst tyvars inst_tys
 
 -- | Returns the argument types of the wrapper, excluding all dictionary arguments
 -- and without substituting for any type variables
 dataConOrigArgTys :: DataCon -> [Type]
 dataConOrigArgTys dc = dcOrigArgTys dc
 
--- | Returns the arg types of the worker, including *all*
+-- | Returns the arg types of the worker, including *all* non-dependent
 -- evidence, after any flattening has been done and without substituting for
 -- any type variables
 dataConRepArgTys :: DataCon -> [Type]
@@ -1198,26 +1371,6 @@ isVanillaDataCon dc = dcVanilla dc
 specialPromotedDc :: DataCon -> Bool
 specialPromotedDc = isKindTyCon . dataConTyCon
 
--- | Was this datacon promotable before GHC 8.0? That is, is it promotable
--- without -XTypeInType
-isLegacyPromotableDataCon :: DataCon -> Bool
-isLegacyPromotableDataCon dc
-  =  null (dataConEqSpec dc)  -- no GADTs
-  && null (dataConTheta dc)   -- no context
-  && not (isFamInstTyCon (dataConTyCon dc))   -- no data instance constructors
-  && uniqSetAll isLegacyPromotableTyCon (tyConsOfType (dataConUserType dc))
-
--- | Was this tycon promotable before GHC 8.0? That is, is it promotable
--- without -XTypeInType
-isLegacyPromotableTyCon :: TyCon -> Bool
-isLegacyPromotableTyCon tc
-  = isVanillaAlgTyCon tc ||
-      -- This returns True more often than it should, but it's quite painful
-      -- to make this fully accurate. And no harm is caused; we just don't
-      -- require -XTypeInType every time we need to. (We'll always require
-      -- -XDataKinds, though, so there's no standards-compliance issue.)
-    isFunTyCon tc || isKindTyCon tc
-
 classDataCon :: Class -> DataCon
 classDataCon clas = case tyConDataCons (classTyCon clas) of
                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
@@ -1241,6 +1394,23 @@ dataConCannotMatch tys con
                        | eq `hasKey` eqTyConKey -> [(ty1, ty2)]
                      _                          -> []
 
+-- | Were the type variables of the data con written in a different order
+-- than the regular order (universal tyvars followed by existential tyvars)?
+--
+-- This is not a cheap test, so we minimize its use in GHC as much as possible.
+-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in
+-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once
+-- during a data constructor's lifetime.
+
+-- See Note [DataCon user type variable binders], as well as
+-- Note [Data con wrappers and GADT syntax] for an explanation of what
+-- mkDataConRep is doing with this function.
+dataConUserTyVarsArePermuted :: DataCon -> Bool
+dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs
+                                     , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec
+                                     , dcUserTyVarBinders = user_tvbs }) =
+  (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -1319,8 +1489,8 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
   where
     binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
 
-buildSynTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind
-                  -> [Role] -> Type -> TyCon
+buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind
+              -> [Role] -> KnotTied Type -> TyCon
 buildSynTyCon name binders res_kind roles rhs
   = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
   where
diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot
index 0938b9b963..a69133463b 100644
--- a/compiler/basicTypes/DataCon.hs-boot
+++ b/compiler/basicTypes/DataCon.hs-boot
@@ -1,5 +1,7 @@
 module DataCon where
-import Var( TyVar, TyVarBinder )
+
+import GhcPrelude
+import Var( TyVar, TyCoVar, TyVarBinder )
 import Name( Name, NamedThing )
 import {-# SOURCE #-} TyCon( TyCon )
 import FieldLabel ( FieldLabel )
@@ -11,19 +13,19 @@ import {-# SOURCE #-} TyCoRep ( Type, ThetaType )
 data DataCon
 data DataConRep
 data EqSpec
-filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]
 
 dataConName      :: DataCon -> Name
 dataConTyCon     :: DataCon -> TyCon
-dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]
-dataConExTyVars  :: DataCon -> [TyVar]
-dataConExTyVarBinders :: DataCon -> [TyVarBinder]
+dataConExTyCoVars :: DataCon -> [TyCoVar]
+dataConUserTyVars :: DataCon -> [TyVar]
+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
 dataConSourceArity  :: DataCon -> Arity
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
 dataConStupidTheta :: DataCon -> ThetaType
 dataConFullSig :: DataCon
-               -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type)
+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type)
+isUnboxedSumCon :: DataCon -> Bool
 
 instance Eq DataCon
 instance Uniquable DataCon
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index dfff0a2c92..071945386e 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -39,7 +39,7 @@ module Demand (
         nopSig, botSig, exnSig, cprProdSig,
         isTopSig, hasDemandEnvSig,
         splitStrictSig, strictSigDmdEnv,
-        increaseStrictSigArity,
+        increaseStrictSigArity, etaExpandStrictSig,
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig,
 
@@ -62,6 +62,8 @@ module Demand (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import Outputable
 import Var ( Var )
@@ -1440,6 +1442,7 @@ postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)
 postProcessDmdResult :: Str () -> DmdResult -> DmdResult
 postProcessDmdResult Lazy           _         = topRes
 postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes  -- Key point!
+-- Note that only ThrowsExn results can be caught, not Diverges
 postProcessDmdResult _              res       = res
 
 postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv
@@ -1734,8 +1737,23 @@ splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 
 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
 -- Add extra arguments to a strictness signature
-increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
-  = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
+increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))
+  | isTopDmdType dmd_ty = sig
+  | arity_increase <= 0 = sig
+  | otherwise           = StrictSig (DmdType env dmds' res)
+  where
+    dmds' = replicate arity_increase topDmd ++ dmds
+
+etaExpandStrictSig :: Arity -> StrictSig -> StrictSig
+-- We are expanding (\x y. e) to (\x y z. e z)
+-- Add exta demands to the /end/ of the arg demands if necessary
+etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res))
+  | isTopDmdType dmd_ty = sig
+  | arity_increase <= 0 = sig
+  | otherwise           = StrictSig (DmdType env dmds' res)
+  where
+    arity_increase = arity - length dmds
+    dmds' = dmds ++ replicate arity_increase topDmd
 
 isTopSig :: StrictSig -> Bool
 isTopSig (StrictSig ty) = isTopDmdType ty
diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs
index 8548fd2b72..d73dbd3ad3 100644
--- a/compiler/basicTypes/FieldLabel.hs
+++ b/compiler/basicTypes/FieldLabel.hs
@@ -69,6 +69,8 @@ module FieldLabel ( FieldLabelString
                   , mkFieldLabelOccs
                   ) where
 
+import GhcPrelude
+
 import OccName
 import Name
 
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 290e26291d..c1d281edd6 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -5,7 +5,7 @@
 \section[Id]{@Ids@: Value and constructor identifiers}
 -}
 
-{-# LANGUAGE ImplicitParams, CPP #-}
+{-# LANGUAGE CPP #-}
 
 -- |
 -- #name_types#
@@ -116,8 +116,11 @@ module Id (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
-import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, Unfolding( NoUnfolding ) )
+import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
+                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -201,7 +204,7 @@ setIdNotExported :: Id -> Id
 setIdNotExported = Var.setIdNotExported
 
 localiseId :: Id -> Id
--- Make an with the same unique and type as the
+-- Make an Id with the same unique and type as the
 -- incoming Id, but with an *Internal* Name and *LocalId* flavour
 localiseId id
   | ASSERT( isId id ) isLocalId id && isInternalName name
@@ -216,9 +219,9 @@ lazySetIdInfo = Var.lazySetIdInfo
 
 setIdInfo :: Id -> IdInfo -> Id
 setIdInfo id info = info `seq` (lazySetIdInfo id info)
-        -- Try to avoid spack leaks by seq'ing
+        -- Try to avoid space leaks by seq'ing
 
-modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
+modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
 modifyIdInfo fn id = setIdInfo id (fn (idInfo id))
 
 -- maybeModifyIdInfo tries to avoid unnecessary thrashing
@@ -513,7 +516,8 @@ hasNoBinding id = case Var.idDetails id of
                         PrimOpId _       -> True        -- See Note [Primop wrappers]
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
-                        _                -> False
+                        _                -> isCompulsoryUnfolding (idUnfolding id)
+                                            -- See Note [Levity-polymorphic Ids]
 
 isImplicitId :: Id -> Bool
 -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other
@@ -535,7 +539,25 @@ isImplicitId id
 idIsFrom :: Module -> Id -> Bool
 idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
 
-{-
+{- Note [Levity-polymorphic Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some levity-polymorphic Ids must be applied and and inlined, not left
+un-saturated.  Example:
+  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b
+
+This has a compulsory unfolding because we can't lambda-bind those
+arguments.  But the compulsory unfolding may leave levity-polymorphic
+lambdas if it is not applied to enough arguments; e.g. (Trac #14561)
+  bad :: forall (a :: TYPE r). a -> a
+  bad = unsafeCoerce#
+
+The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
+And we want that magic to apply to levity-polymorphic compulsory-inline things.
+The easiest way to do this is for hasNoBinding to return True of all things
+that have compulsory unfolding.  A very Ids with a compulsory unfolding also
+have a binding, but it does not harm to say they don't here, and its a very
+simple way to fix Trac #14561.
+
 Note [Primop wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~
 Currently hasNoBinding claims that PrimOpIds don't have a curried
@@ -715,7 +737,7 @@ setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
         ---------------------------------
-        -- Occcurrence INFO
+        -- Occurrence INFO
 idOccInfo :: Id -> OccInfo
 idOccInfo id = occInfo (idInfo id)
 
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index bd6ec8f293..12ea490a53 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -29,7 +29,7 @@ module IdInfo (
         -- ** Zapping various forms of Info
         zapLamInfo, zapFragileInfo,
         zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
-        zapTailCallInfo, zapCallArityInfo,
+        zapTailCallInfo, zapCallArityInfo, zapUnfolding,
 
         -- ** The ArityInfo type
         ArityInfo,
@@ -82,6 +82,8 @@ module IdInfo (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 
 import Class
@@ -261,7 +263,7 @@ setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
 setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
 setOccInfo :: IdInfo -> OccInfo -> IdInfo
 setOccInfo        info oc = oc `seq` info { occInfo = oc }
-        -- Try to avoid spack leaks by seq'ing
+        -- Try to avoid space leaks by seq'ing
 
 setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
 setUnfoldingInfo info uf
@@ -545,6 +547,11 @@ zapFragileUnfolding unf
  | isFragileUnfolding unf = noUnfolding
  | otherwise              = unf
 
+zapUnfolding :: Unfolding -> Unfolding
+-- Squash all unfolding info, preserving only evaluated-ness
+zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding
+                 | otherwise            = noUnfolding
+
 zapTailCallInfo :: IdInfo -> Maybe IdInfo
 zapTailCallInfo info
   = case occInfo info of
diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot
index 0fabad3bbb..cacfe6af2e 100644
--- a/compiler/basicTypes/IdInfo.hs-boot
+++ b/compiler/basicTypes/IdInfo.hs-boot
@@ -1,4 +1,5 @@
 module IdInfo where
+import GhcPrelude
 import Outputable
 data IdInfo
 data IdDetails
diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs
index dadc79ce21..d397deaea8 100644
--- a/compiler/basicTypes/Lexeme.hs
+++ b/compiler/basicTypes/Lexeme.hs
@@ -2,7 +2,7 @@
 --
 -- Functions to evaluate whether or not a string is a valid identifier.
 -- There is considerable overlap between the logic here and the logic
--- in Lexer.x, but sadly there seems to be way to merge them.
+-- in Lexer.x, but sadly there seems to be no way to merge them.
 
 module Lexeme (
           -- * Lexical characteristics of Haskell names
@@ -27,6 +27,8 @@ module Lexeme (
 
   ) where
 
+import GhcPrelude
+
 import FastString
 
 import Data.Char
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index f14606e8cf..21f4a92290 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -5,26 +5,30 @@
 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
 -}
 
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
 
 module Literal
         (
         -- * Main data type
           Literal(..)           -- Exported to ParseIface
+        , LitNumType(..)
 
         -- ** Creating Literals
-        , mkMachInt, mkMachIntWrap
-        , mkMachWord, mkMachWordWrap
+        , mkMachInt, mkMachIntWrap, mkMachIntWrapC
+        , mkMachWord, mkMachWordWrap, mkMachWordWrapC
         , mkMachInt64, mkMachInt64Wrap
         , mkMachWord64, mkMachWord64Wrap
         , mkMachFloat, mkMachDouble
         , mkMachChar, mkMachString
-        , mkLitInteger
+        , mkLitInteger, mkLitNatural
+        , mkLitNumber, mkLitNumberWrap
 
         -- ** Operations on Literals
         , literalType
         , absentLiteralOf
         , pprLiteral
+        , litNumIsSigned
+        , litNumCheckRange
 
         -- ** Predicates on Literals and their contents
         , litIsDupable, litIsTrivial, litIsLifted
@@ -35,6 +39,7 @@ module Literal
 
         -- ** Coercions
         , word2IntLit, int2WordLit
+        , narrowLit
         , narrow8IntLit, narrow16IntLit, narrow32IntLit
         , narrow8WordLit, narrow16WordLit, narrow32WordLit
         , char2IntLit, int2CharLit
@@ -44,6 +49,8 @@ module Literal
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TysPrim
 import PrelNames
 import Type
@@ -64,6 +71,7 @@ import Data.Word
 import Data.Char
 import Data.Maybe ( isJust )
 import Data.Data ( Data )
+import Data.Proxy
 import Numeric ( fromRat )
 
 {-
@@ -93,6 +101,10 @@ data Literal
         -- First the primitive guys
     MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
 
+  | LitNumber !LitNumType !Integer Type
+      --  ^ Any numeric literal that can be
+      -- internally represented with an Integer
+
   | MachStr     ByteString      -- ^ A string-literal: stored and emitted
                                 -- UTF-8 encoded, we'll arrange to decode it
                                 -- at runtime.  Also emitted with a @'\0'@
@@ -102,11 +114,6 @@ data Literal
                                 -- that can be represented as a Literal. Create
                                 -- with 'nullAddrLit'
 
-  | MachInt     Integer         -- ^ @Int#@ - according to target machine
-  | MachInt64   Integer         -- ^ @Int64#@ - exactly 64 bits
-  | MachWord    Integer         -- ^ @Word#@ - according to target machine
-  | MachWord64  Integer         -- ^ @Word64#@ - exactly 64 bits
-
   | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'
   | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'
 
@@ -121,11 +128,28 @@ data Literal
                 --    the label expects. Only applicable with
                 --    @stdcall@ labels. @Just x@ => @\<x\>@ will
                 --    be appended to label name when emitting assembly.
-
-  | LitInteger Integer Type --  ^ Integer literals
-                            -- See Note [Integer literals]
   deriving Data
 
+-- | Numeric literal type
+data LitNumType
+  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
+  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
+  | LitNumInt     -- ^ @Int#@ - according to target machine
+  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits
+  | LitNumWord    -- ^ @Word#@ - according to target machine
+  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
+  deriving (Data,Enum,Eq,Ord)
+
+-- | Indicate if a numeric literal type supports negative numbers
+litNumIsSigned :: LitNumType -> Bool
+litNumIsSigned nt = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> False
+  LitNumWord64  -> False
+
 {-
 Note [Integer literals]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -144,26 +168,33 @@ below), we don't have convenient access to the mkInteger Id.  So we
 just use an error thunk, and fill in the real Id when we do tcIfaceLit
 in TcIface.
 
+Note [Natural literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+Similar to Integer literals.
 
-Binary instance
 -}
 
+instance Binary LitNumType where
+   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
+   get bh = do
+      h <- getByte bh
+      return (toEnum (fromIntegral h))
+
 instance Binary Literal where
     put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa
     put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab
     put_ bh (MachNullAddr)    = do putByte bh 2
-    put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad
-    put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae
-    put_ bh (MachWord af)     = do putByte bh 5; put_ bh af
-    put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag
-    put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah
-    put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai
+    put_ bh (MachFloat ah)    = do putByte bh 3; put_ bh ah
+    put_ bh (MachDouble ai)   = do putByte bh 4; put_ bh ai
     put_ bh (MachLabel aj mb fod)
-        = do putByte bh 9
+        = do putByte bh 5
              put_ bh aj
              put_ bh mb
              put_ bh fod
-    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
+    put_ bh (LitNumber nt i _)
+        = do putByte bh 6
+             put_ bh nt
+             put_ bh i
     get bh = do
             h <- getByte bh
             case h of
@@ -176,32 +207,31 @@ instance Binary Literal where
               2 -> do
                     return (MachNullAddr)
               3 -> do
-                    ad <- get bh
-                    return (MachInt ad)
-              4 -> do
-                    ae <- get bh
-                    return (MachInt64 ae)
-              5 -> do
-                    af <- get bh
-                    return (MachWord af)
-              6 -> do
-                    ag <- get bh
-                    return (MachWord64 ag)
-              7 -> do
                     ah <- get bh
                     return (MachFloat ah)
-              8 -> do
+              4 -> do
                     ai <- get bh
                     return (MachDouble ai)
-              9 -> do
+              5 -> do
                     aj <- get bh
                     mb <- get bh
                     fod <- get bh
                     return (MachLabel aj mb fod)
               _ -> do
-                    i <- get bh
-                    -- See Note [Integer literals]
-                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
+                    nt <- get bh
+                    i  <- get bh
+                    let t = case nt of
+                            LitNumInt     -> intPrimTy
+                            LitNumInt64   -> int64PrimTy
+                            LitNumWord    -> wordPrimTy
+                            LitNumWord64  -> word64PrimTy
+                            -- See Note [Integer literals]
+                            LitNumInteger ->
+                              panic "Evaluated the place holder for mkInteger"
+                            -- and Note [Natural literals]
+                            LitNumNatural ->
+                              panic "Evaluated the place holder for mkNatural"
+                    return (LitNumber nt i t)
 
 instance Outputable Literal where
     ppr lit = pprLiteral (\d -> d) lit
@@ -240,55 +270,116 @@ doesn't yield a warning. Instead we simply squash the value into the *target*
 Int/Word range.
 -}
 
+-- | Wrap a literal number according to its type
+wrapLitNumber :: DynFlags -> Literal -> Literal
+wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
+  LitNumInt -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumWord -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+  LitNumInteger -> v
+  LitNumNatural -> v
+wrapLitNumber _ x = x
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)
+
+-- | Check that a given number is in the range of a numeric literal
+litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
+litNumCheckRange dflags nt i = case nt of
+     LitNumInt     -> inIntRange dflags i
+     LitNumWord    -> inWordRange dflags i
+     LitNumInt64   -> inInt64Range i
+     LitNumWord64  -> inWord64Range i
+     LitNumNatural -> i >= 0
+     LitNumInteger -> True
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumber dflags nt i t =
+  ASSERT2(litNumCheckRange dflags nt i, integer i)
+  (LitNumber nt i t)
+
 -- | Creates a 'Literal' of type @Int#@
 mkMachInt :: DynFlags -> Integer -> Literal
 mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
-                       MachInt x
+                       (mkMachIntUnchecked x)
 
 -- | Creates a 'Literal' of type @Int#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
 --   See Note [Word/Int underflow/overflow]
 mkMachIntWrap :: DynFlags -> Integer -> Literal
-mkMachIntWrap dflags i
- = MachInt $ case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromIntegral i :: Int32)
-   8 -> toInteger (fromIntegral i :: Int64)
-   w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
+mkMachIntWrap dflags i = wrapLitNumber dflags $ mkMachIntUnchecked i
+
+-- | Creates a 'Literal' of type @Int#@ without checking its range.
+mkMachIntUnchecked :: Integer -> Literal
+mkMachIntUnchecked i = LitNumber LitNumInt i intPrimTy
+
+-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
+--   overflow. That is, if the argument is out of the (target-dependent) range
+--   the argument is wrapped and the overflow flag will be set.
+--   See Note [Word/Int underflow/overflow]
+mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
+mkMachIntWrapC dflags i = (n, i /= i')
+  where
+    n@(LitNumber _ i' _) = mkMachIntWrap dflags i
 
 -- | Creates a 'Literal' of type @Word#@
 mkMachWord :: DynFlags -> Integer -> Literal
 mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
-                        MachWord x
+                        (mkMachWordUnchecked x)
 
 -- | Creates a 'Literal' of type @Word#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
 --   See Note [Word/Int underflow/overflow]
 mkMachWordWrap :: DynFlags -> Integer -> Literal
-mkMachWordWrap dflags i
- = MachWord $ case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromInteger i :: Word32)
-   8 -> toInteger (fromInteger i :: Word64)
-   w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
+mkMachWordWrap dflags i = wrapLitNumber dflags $ mkMachWordUnchecked i
+
+-- | Creates a 'Literal' of type @Word#@ without checking its range.
+mkMachWordUnchecked :: Integer -> Literal
+mkMachWordUnchecked i = LitNumber LitNumWord i wordPrimTy
+
+-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
+--   carry. That is, if the argument is out of the (target-dependent) range
+--   the argument is wrapped and the carry flag will be set.
+--   See Note [Word/Int underflow/overflow]
+mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
+mkMachWordWrapC dflags i = (n, i /= i')
+  where
+    n@(LitNumber _ i' _) = mkMachWordWrap dflags i
 
 -- | Creates a 'Literal' of type @Int64#@
 mkMachInt64 :: Integer -> Literal
-mkMachInt64  x = ASSERT2( inInt64Range x, integer x )
-                 MachInt64 x
+mkMachInt64  x = ASSERT2( inInt64Range x, integer x ) (mkMachInt64Unchecked x)
 
 -- | Creates a 'Literal' of type @Int64#@.
 --   If the argument is out of the range, it is wrapped.
-mkMachInt64Wrap :: Integer -> Literal
-mkMachInt64Wrap  i = MachInt64 (toInteger (fromIntegral i :: Int64))
+mkMachInt64Wrap :: DynFlags -> Integer -> Literal
+mkMachInt64Wrap dflags i = wrapLitNumber dflags $ mkMachInt64Unchecked i
+
+-- | Creates a 'Literal' of type @Int64#@ without checking its range.
+mkMachInt64Unchecked :: Integer -> Literal
+mkMachInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
 
 -- | Creates a 'Literal' of type @Word64#@
 mkMachWord64 :: Integer -> Literal
-mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
-                 MachWord64 x
+mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) (mkMachWord64Unchecked x)
 
 -- | Creates a 'Literal' of type @Word64#@.
 --   If the argument is out of the range, it is wrapped.
-mkMachWord64Wrap :: Integer -> Literal
-mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
+mkMachWord64Wrap :: DynFlags -> Integer -> Literal
+mkMachWord64Wrap dflags i = wrapLitNumber dflags $ mkMachWord64Unchecked i
+
+-- | Creates a 'Literal' of type @Word64#@ without checking its range.
+mkMachWord64Unchecked :: Integer -> Literal
+mkMachWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
 
 -- | Creates a 'Literal' of type @Float#@
 mkMachFloat :: Rational -> Literal
@@ -309,12 +400,19 @@ mkMachString :: String -> Literal
 mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
 
 mkLitInteger :: Integer -> Type -> Literal
-mkLitInteger = LitInteger
+mkLitInteger x ty = LitNumber LitNumInteger x ty
+
+mkLitNatural :: Integer -> Type -> Literal
+mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
+                    (LitNumber LitNumNatural x ty)
 
 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
 inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
 inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags
 
+inNaturalRange :: Integer -> Bool
+inNaturalRange x = x >= 0
+
 inInt64Range, inWord64Range :: Integer -> Bool
 inInt64Range x  = x >= toInteger (minBound :: Int64) &&
                   x <= toInteger (maxBound :: Int64)
@@ -326,49 +424,39 @@ inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
 
 -- | Tests whether the literal represents a zero of whatever type it is
 isZeroLit :: Literal -> Bool
-isZeroLit (MachInt    0) = True
-isZeroLit (MachInt64  0) = True
-isZeroLit (MachWord   0) = True
-isZeroLit (MachWord64 0) = True
-isZeroLit (MachFloat  0) = True
-isZeroLit (MachDouble 0) = True
-isZeroLit _              = False
+isZeroLit (LitNumber _ 0 _) = True
+isZeroLit (MachFloat  0)    = True
+isZeroLit (MachDouble 0)    = True
+isZeroLit _                 = False
 
 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
 litValue  :: Literal -> Integer
 litValue l = case isLitValue_maybe l of
    Just x  -> x
    Nothing -> pprPanic "litValue" (ppr l)
 
 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char' and numbers.
 isLitValue_maybe  :: Literal -> Maybe Integer
-isLitValue_maybe (MachChar   c)   = Just $ toInteger $ ord c
-isLitValue_maybe (MachInt    i)   = Just i
-isLitValue_maybe (MachInt64  i)   = Just i
-isLitValue_maybe (MachWord   i)   = Just i
-isLitValue_maybe (MachWord64 i)   = Just i
-isLitValue_maybe (LitInteger i _) = Just i
-isLitValue_maybe _                = Nothing
+isLitValue_maybe (MachChar   c)    = Just $ toInteger $ ord c
+isLitValue_maybe (LitNumber _ i _) = Just i
+isLitValue_maybe _                 = Nothing
 
 -- | Apply a function to the 'Integer' contained in the 'Literal', for when that
--- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
--- fixed-size integral literals, the result will be wrapped in
--- accordance with the semantics of the target type.
+-- makes sense, e.g. for 'Char' and numbers.
+-- For fixed-size integral literals, the result will be wrapped in accordance
+-- with the semantics of the target type.
 -- See Note [Word/Int underflow/overflow]
 mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
-mapLitValue _      f (MachChar   c)   = mkMachChar (fchar c)
+mapLitValue _      f (MachChar   c)     = mkMachChar (fchar c)
    where fchar = chr . fromInteger . f . toInteger . ord
-mapLitValue dflags f (MachInt    i)   = mkMachIntWrap dflags (f i)
-mapLitValue _      f (MachInt64  i)   = mkMachInt64Wrap (f i)
-mapLitValue dflags f (MachWord   i)   = mkMachWordWrap dflags (f i)
-mapLitValue _      f (MachWord64 i)   = mkMachWord64Wrap (f i)
-mapLitValue _      f (LitInteger i t) = mkLitInteger (f i) t
-mapLitValue _      _ l                = pprPanic "mapLitValue" (ppr l)
+mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
+                                                        (LitNumber nt (f i) t)
+mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)
 
 -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
--- 'Int', 'Word' and 'LitInteger'.
+-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
 isLitValue  :: Literal -> Bool
 isLitValue = isJust . isLitValue_maybe
 
@@ -385,43 +473,42 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit,
   :: Literal -> Literal
 
 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
-word2IntLit dflags (MachWord w)
-  | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
-  | otherwise                 = MachInt w
+word2IntLit dflags (LitNumber LitNumWord w _)
+  | w > tARGET_MAX_INT dflags = mkMachInt dflags (w - tARGET_MAX_WORD dflags - 1)
+  | otherwise                 = mkMachInt dflags w
 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
 
-int2WordLit dflags (MachInt i)
-  | i < 0     = MachWord (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
-  | otherwise = MachWord i
+int2WordLit dflags (LitNumber LitNumInt i _)
+  | i < 0     = mkMachWord dflags (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
+  | otherwise = mkMachWord dflags i
 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
 
-narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
-narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)
-narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
-narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)
-narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
-narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)
-narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
-narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)
-narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
-narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)
-narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
-narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)
-
-char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
+-- | Narrow a literal number (unchecked result range)
+narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
+narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
+narrowLit _ l                  = pprPanic "narrowLit" (ppr l)
+
+narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)
+narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)
+narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)
+narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)
+narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
+narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+
+char2IntLit (MachChar c) = mkMachIntUnchecked (toInteger (ord c))
 char2IntLit l            = pprPanic "char2IntLit" (ppr l)
-int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
-int2CharLit l            = pprPanic "int2CharLit" (ppr l)
+int2CharLit (LitNumber _ i _) = MachChar (chr (fromInteger i))
+int2CharLit l                 = pprPanic "int2CharLit" (ppr l)
 
-float2IntLit (MachFloat f) = MachInt   (truncate    f)
+float2IntLit (MachFloat f) = mkMachIntUnchecked (truncate f)
 float2IntLit l             = pprPanic "float2IntLit" (ppr l)
-int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
-int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)
+int2FloatLit (LitNumber _ i _) = MachFloat (fromInteger i)
+int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)
 
-double2IntLit (MachDouble f) = MachInt    (truncate    f)
+double2IntLit (MachDouble f) = mkMachIntUnchecked (truncate f)
 double2IntLit l              = pprPanic "double2IntLit" (ppr l)
-int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)
-int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)
+int2DoubleLit (LitNumber _ i _) = MachDouble (fromInteger i)
+int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)
 
 float2DoubleLit (MachFloat  f) = MachDouble f
 float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)
@@ -472,24 +559,41 @@ nullAddrLit = MachNullAddr
 litIsTrivial :: Literal -> Bool
 --      c.f. CoreUtils.exprIsTrivial
 litIsTrivial (MachStr _)      = False
-litIsTrivial (LitInteger {})  = False
+litIsTrivial (LitNumber nt _ _) = case nt of
+  LitNumInteger -> False
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
 litIsTrivial _                = True
 
 -- | True if code space does not go bad if we duplicate this literal
--- Currently we treat it just like 'litIsTrivial'
 litIsDupable :: DynFlags -> Literal -> Bool
 --      c.f. CoreUtils.exprIsDupable
 litIsDupable _      (MachStr _)      = False
-litIsDupable dflags (LitInteger i _) = inIntRange dflags i
+litIsDupable dflags (LitNumber nt i _) = case nt of
+  LitNumInteger -> inIntRange dflags i
+  LitNumNatural -> inIntRange dflags i
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
 litIsDupable _      _                = True
 
 litFitsInChar :: Literal -> Bool
-litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
-                         && i <= toInteger (ord maxBound)
-litFitsInChar _           = False
+litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
+                               && i <= toInteger (ord maxBound)
+litFitsInChar _                 = False
 
 litIsLifted :: Literal -> Bool
-litIsLifted (LitInteger {}) = True
+litIsLifted (LitNumber nt _ _) = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> True
+  LitNumInt     -> False
+  LitNumInt64   -> False
+  LitNumWord    -> False
+  LitNumWord64  -> False
 litIsLifted _               = False
 
 {-
@@ -499,32 +603,29 @@ litIsLifted _               = False
 
 -- | Find the Haskell 'Type' the literal occupies
 literalType :: Literal -> Type
-literalType MachNullAddr    = addrPrimTy
-literalType (MachChar _)    = charPrimTy
-literalType (MachStr  _)    = addrPrimTy
-literalType (MachInt  _)    = intPrimTy
-literalType (MachWord  _)   = wordPrimTy
-literalType (MachInt64  _)  = int64PrimTy
-literalType (MachWord64  _) = word64PrimTy
-literalType (MachFloat _)   = floatPrimTy
-literalType (MachDouble _)  = doublePrimTy
+literalType MachNullAddr      = addrPrimTy
+literalType (MachChar _)      = charPrimTy
+literalType (MachStr  _)      = addrPrimTy
+literalType (MachFloat _)     = floatPrimTy
+literalType (MachDouble _)    = doublePrimTy
 literalType (MachLabel _ _ _) = addrPrimTy
-literalType (LitInteger _ t) = t
+literalType (LitNumber _ _ t) = t
 
 absentLiteralOf :: TyCon -> Maybe Literal
--- Return a literal of the appropriate primtive
+-- Return a literal of the appropriate primitive
 -- TyCon, to use as a placeholder when it doesn't matter
 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
 
 absent_lits :: UniqFM Literal
 absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
                         , (charPrimTyConKey,    MachChar 'x')
-                        , (intPrimTyConKey,     MachInt 0)
-                        , (int64PrimTyConKey,   MachInt64 0)
+                        , (intPrimTyConKey,     mkMachIntUnchecked 0)
+                        , (int64PrimTyConKey,   mkMachInt64Unchecked 0)
+                        , (wordPrimTyConKey,    mkMachWordUnchecked 0)
+                        , (word64PrimTyConKey,  mkMachWord64Unchecked 0)
                         , (floatPrimTyConKey,   MachFloat 0)
                         , (doublePrimTyConKey,  MachDouble 0)
-                        , (wordPrimTyConKey,    MachWord 0)
-                        , (word64PrimTyConKey,  MachWord64 0) ]
+                        ]
 
 {-
         Comparison
@@ -532,32 +633,27 @@ absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
 -}
 
 cmpLit :: Literal -> Literal -> Ordering
-cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
-cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
-cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
-cmpLit (MachInt       a)   (MachInt        b)   = a `compare` b
-cmpLit (MachWord      a)   (MachWord       b)   = a `compare` b
-cmpLit (MachInt64     a)   (MachInt64      b)   = a `compare` b
-cmpLit (MachWord64    a)   (MachWord64     b)   = a `compare` b
-cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b
-cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b
+cmpLit (MachChar      a)     (MachChar       b)     = a `compare` b
+cmpLit (MachStr       a)     (MachStr        b)     = a `compare` b
+cmpLit (MachNullAddr)        (MachNullAddr)         = EQ
+cmpLit (MachFloat     a)     (MachFloat      b)     = a `compare` b
+cmpLit (MachDouble    a)     (MachDouble     b)     = a `compare` b
 cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
-cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b
-cmpLit lit1                lit2                 | litTag lit1 < litTag lit2 = LT
-                                                | otherwise                 = GT
+cmpLit (LitNumber nt1 a _)   (LitNumber nt2  b _)
+  | nt1 == nt2 = a   `compare` b
+  | otherwise  = nt1 `compare` nt2
+cmpLit lit1 lit2
+  | litTag lit1 < litTag lit2 = LT
+  | otherwise                 = GT
 
 litTag :: Literal -> Int
 litTag (MachChar      _)   = 1
 litTag (MachStr       _)   = 2
 litTag (MachNullAddr)      = 3
-litTag (MachInt       _)   = 4
-litTag (MachWord      _)   = 5
-litTag (MachInt64     _)   = 6
-litTag (MachWord64    _)   = 7
-litTag (MachFloat     _)   = 8
-litTag (MachDouble    _)   = 9
-litTag (MachLabel _ _ _)   = 10
-litTag (LitInteger  {})    = 11
+litTag (MachFloat     _)   = 4
+litTag (MachDouble    _)   = 5
+litTag (MachLabel _ _ _)   = 6
+litTag (LitNumber  {})     = 7
 
 {-
         Printing
@@ -569,13 +665,16 @@ pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
 pprLiteral _       (MachChar c)     = pprPrimChar c
 pprLiteral _       (MachStr s)      = pprHsBytes s
 pprLiteral _       (MachNullAddr)   = text "__NULL"
-pprLiteral _       (MachInt i)      = pprPrimInt i
-pprLiteral _       (MachInt64 i)    = pprPrimInt64 i
-pprLiteral _       (MachWord w)     = pprPrimWord w
-pprLiteral _       (MachWord64 w)   = pprPrimWord64 w
 pprLiteral _       (MachFloat f)    = float (fromRat f) <> primFloatSuffix
 pprLiteral _       (MachDouble d)   = double (fromRat d) <> primDoubleSuffix
-pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
+pprLiteral add_par (LitNumber nt i _)
+   = case nt of
+       LitNumInteger -> pprIntegerVal add_par i
+       LitNumNatural -> pprIntegerVal add_par i
+       LitNumInt     -> pprPrimInt i
+       LitNumInt64   -> pprPrimInt64 i
+       LitNumWord    -> pprPrimWord i
+       LitNumWord64  -> pprPrimWord64 i
 pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
     where b = case mb of
               Nothing -> pprHsString l
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index a404e74e12..5a6f1fbf96 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -19,17 +19,14 @@ module MkId (
 
         mkPrimOpId, mkFCallId,
 
-        wrapNewTypeBody, unwrapNewTypeBody,
-        wrapFamInstBody, unwrapFamInstScrut,
-        wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut,
-
+        unwrapNewTypeBody, wrapFamInstBody,
         DataConBoxer(..), mkDataConRep, mkDataConWorkId,
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
         voidPrimId, voidArgId,
-        nullAddrId, seqId, lazyId, lazyIdKey, runRWId,
+        nullAddrId, seqId, lazyId, lazyIdKey,
         coercionTokenId, magicDictId, coerceId,
         proxyHashId, noinlineId, noinlineIdName,
 
@@ -39,6 +36,8 @@ module MkId (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Rules
 import TysPrim
 import TysWiredIn
@@ -52,7 +51,6 @@ import CoreUtils        ( exprType, mkCast )
 import CoreUnfold
 import Literal
 import TyCon
-import CoAxiom
 import Class
 import NameSet
 import Name
@@ -86,59 +84,75 @@ import Data.Maybe       ( maybeToList )
 
 Note [Wired-in Ids]
 ~~~~~~~~~~~~~~~~~~~
+A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')
+rather than by looking it up its name in some environment or fetching
+it from an interface file.
+
 There are several reasons why an Id might appear in the wiredInIds:
 
-(1) The ghcPrimIds are wired in because they can't be defined in
-    Haskell at all, although the can be defined in Core.  They have
-    compulsory unfoldings, so they are always inlined and they  have
-    no definition site.  Their home module is GHC.Prim, so they
-    also have a description in primops.txt.pp, where they are called
-    'pseudoops'.
+* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]
+
+* magicIds: see Note [magicIds]
+
+* errorIds, defined in coreSyn/MkCore.hs.
+  These error functions (e.g. rUNTIME_ERROR_ID) are wired in
+  because the desugarer generates code that mentions them directly
+
+In all cases except ghcPrimIds, there is a definition site in a
+library module, which may be called (e.g. in higher order situations);
+but the wired-in version means that the details are never read from
+that module's interface file; instead, the full definition is right
+here.
+
+Note [ghcPrimIds (aka pseudoops)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ghcPrimIds
+
+  * Are exported from GHC.Prim
+
+  * Can't be defined in Haskell, and hence no Haskell binding site,
+    but have perfectly reasonable unfoldings in Core
+
+  * Either have a CompulsoryUnfolding (hence always inlined), or
+        of an EvaldUnfolding and void representation (e.g. void#)
 
-(2) The 'error' function, eRROR_ID, is wired in because we don't yet have
-    a way to express in an interface file that the result type variable
-    is 'open'; that is can be unified with an unboxed type
+  * Are (or should be) defined in primops.txt.pp as 'pseudoop'
+    Reason: that's how we generate documentation for them
 
-    [The interface file format now carry such information, but there's
-    no way yet of expressing at the definition site for these
-    error-reporting functions that they have an 'open'
-    result type. -- sof 1/99]
+Note [magicIds]
+~~~~~~~~~~~~~~~
+The magicIds
 
-(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
-    the desugarer generates code that mentions them directly, and
-    (b) for the same reason as eRROR_ID
+  * Are exported from GHC.Magic
 
-(4) lazyId is wired in because the wired-in version overrides the
-    strictness of the version defined in GHC.Base
+  * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).
+    This definition at least generates Haddock documentation for them.
 
-(5) noinlineId is wired in because when we serialize to interfaces
-    we may insert noinline statements.
+  * May or may not have a CompulsoryUnfolding.
 
-In cases (2-4), the function has a definition in a library module, and
-can be called; but the wired-in version means that the details are
-never read from that module's interface file; instead, the full definition
-is right here.
+  * But have some special behaviour that can't be done via an
+    unfolding from an interface file
 -}
 
 wiredInIds :: [Id]
 wiredInIds
-  =  [lazyId, dollarId, oneShotId, runRWId, noinlineId]
-  ++ errorIds           -- Defined in MkCore
+  =  magicIds
   ++ ghcPrimIds
+  ++ errorIds           -- Defined in MkCore
+
+magicIds :: [Id]    -- See Note [magicIds]
+magicIds = [lazyId, oneShotId, noinlineId]
 
--- These Ids are exported from GHC.Prim
-ghcPrimIds :: [Id]
+ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
 ghcPrimIds
-  = [   -- These can't be defined in Haskell, but they have
-        -- perfectly reasonable unfoldings in Core
-    realWorldPrimId,
-    voidPrimId,
-    unsafeCoerceId,
-    nullAddrId,
-    seqId,
-    magicDictId,
-    coerceId,
-    proxyHashId
+  = [ realWorldPrimId
+    , voidPrimId
+    , unsafeCoerceId
+    , nullAddrId
+    , seqId
+    , magicDictId
+    , coerceId
+    , proxyHashId
     ]
 
 {-
@@ -232,6 +246,47 @@ Hence we translate to
         -- Coercion from family type to representation type
   Co7T a :: T [a] ~ :R7T a
 
+Newtype instances through an additional wrinkle into the mix. Consider the
+following example (adapted from #15318, comment:2):
+
+  data family T a
+  newtype instance T [a] = MkT [a]
+
+Within the newtype instance, there are three distinct types at play:
+
+1. The newtype's underlying type, [a].
+2. The instance's representation type, TList a (where TList is the
+   representation tycon).
+3. The family type, T [a].
+
+We need two coercions in order to cast from (1) to (3):
+
+(a) A newtype coercion axiom:
+
+      axiom coTList a :: TList a ~ [a]
+
+    (Where TList is the representation tycon of the newtype instance.)
+
+(b) A data family instance coercion axiom:
+
+      axiom coT a :: T [a] ~ TList a
+
+When we translate the newtype instance to Core, we obtain:
+
+    -- Wrapper
+  $WMkT :: forall a. [a] -> T [a]
+  $WMkT a x = MkT a x |> Sym (coT a)
+
+    -- Worker
+  MkT :: forall a. [a] -> TList [a]
+  MkT a x = x |> Sym (coTList a)
+
+Unlike for data instances, the worker for a newtype instance is actually an
+executable function which expands to a cast, but otherwise, the general
+strategy is essentially the same as for data instances. Also note that we have
+a wrapper, which is unusual for a newtype, but we make GHC produce one anyway
+for symmetry with the way data instances are handled.
+
 Note [Newtype datacons]
 ~~~~~~~~~~~~~~~~~~~~~~~
 The "data constructor" for a newtype should always be vanilla.  At one
@@ -276,7 +331,7 @@ mkDictSelId name clas
     sel_names      = map idName (classAllSelIds clas)
     new_tycon      = isNewTyCon tycon
     [data_con]     = tyConDataCons tycon
-    tyvars         = dataConUnivTyVarBinders data_con
+    tyvars         = dataConUserTyVarBinders data_con
     n_ty_args      = length tyvars
     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
@@ -339,7 +394,8 @@ mkDictSelRhs clas val_index
     dict_id        = mkTemplateLocal 1 pred
     arg_ids        = mkTemplateLocalsNum 2 arg_tys
 
-    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id)
+    rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars)
+                                                   (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
                                 [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
                                 -- varToCoreExpr needed for equality superclass selectors
@@ -390,17 +446,19 @@ mkDataConWorkId wkr_name data_con
 
     wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
-        -- Notice that we do *not* say the worker is strict
+        -- Notice that we do *not* say the worker Id is strict
         -- even if the data constructor is declared strict
         --      e.g.    data T = MkT !(Int,Int)
-        -- Why?  Because the *wrapper* is strict (and its unfolding has case
-        -- expressions that do the evals) but the *worker* itself is not.
-        -- If we pretend it is strict then when we see
-        --      case x of y -> $wMkT y
+        -- Why?  Because the *wrapper* $WMkT is strict (and its unfolding has
+        -- case expressions that do the evals) but the *worker* MkT itself is
+        --  not. If we pretend it is strict then when we see
+        --      case x of y -> MkT y
         -- the simplifier thinks that y is "sure to be evaluated" (because
-        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
+        -- the worker MkT is strict) and drops the case.  No, the workerId
+        -- MkT is not strict.
         --
-        -- When the simplifier sees a pattern
+        -- However, the worker does have StrictnessMarks.  When the simplifier
+        -- sees a pattern
         --      case e of MkT x -> ...
         -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
         -- but that's fine... dataConRepStrictness comes from the data con
@@ -408,7 +466,7 @@ mkDataConWorkId wkr_name data_con
 
         ----------- Workers for newtypes --------------
     (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con
-    res_ty_args  = mkTyVarTys nt_tvs
+    res_ty_args  = mkTyCoVarTys nt_tvs
     nt_wrap_ty   = dataConUserType data_con
     nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                   `setArityInfo` 1      -- Arity 1
@@ -427,7 +485,7 @@ dataConCPR :: DataCon -> DmdResult
 dataConCPR con
   | isDataTyCon tycon     -- Real data types only; that is,
                           -- not unboxed tuples or newtypes
-  , null (dataConExTyVars con)  -- No existentials
+  , null (dataConExTyCoVars con)  -- No existentials
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
   = if is_prod then vanillaCprProdRes (dataConRepArity con)
@@ -528,12 +586,16 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
 
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
 
-             wrap_arg_dmds = map mk_dmd arg_ibangs
+             wrap_arg_dmds =
+               replicate (length theta) topDmd ++ map mk_dmd arg_ibangs
+               -- Don't forget the dictionary arguments when building
+               -- the strictness signature (#14290).
+
              mk_dmd str | isBanged str = evalDmd
                         | otherwise           = topDmd
 
              wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
-                         ActiveAfter NoSourceText 2
+                         activeAfterInitial
                          -- See Note [Activation for data constructor wrappers]
 
              -- The wrapper will usually be inlined (see wrap_unf), so its
@@ -545,7 +607,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              -- Passing Nothing here allows the wrapper to inline when
              -- unsaturated.
              wrap_unf = mkInlineUnfolding wrap_rhs
-             wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
              wrap_rhs = mkLams wrap_tvs $
                         mkLams wrap_args $
                         wrapFamInstBody tycon res_ty_args $
@@ -560,6 +621,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
   where
     (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
       = dataConFullSig data_con
+    wrap_tvs     = dataConUserTyVars data_con
     res_ty_args  = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
 
     tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
@@ -570,7 +632,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
     orig_bangs   = dataConSrcBangs data_con
 
     wrap_arg_tys = theta ++ orig_arg_tys
-    wrap_arity   = length wrap_arg_tys
+    wrap_arity   = count isCoVar ex_tvs + length wrap_arg_tys
              -- The wrap_args are the arguments *other than* the eq_spec
              -- Because we are going to apply the eq_spec args manually in the
              -- wrapper
@@ -587,11 +649,20 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
     (unboxers, boxers) = unzip wrappers
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
-    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
-                && (any isBanged (ev_ibangs ++ arg_ibangs)
-                      -- Some forcing/unboxing (includes eq_spec)
-                    || isFamInstTyCon tycon  -- Cast result
-                    || (not $ null eq_spec)) -- GADT
+    wrapper_reqd =
+        (not (isNewTyCon tycon)
+                     -- (Most) newtypes have only a worker, with the exception
+                     -- of some newtypes written with GADT syntax. See below.
+         && (any isBanged (ev_ibangs ++ arg_ibangs)
+                     -- Some forcing/unboxing (includes eq_spec)
+             || (not $ null eq_spec))) -- GADT
+      || isFamInstTyCon tycon -- Cast result
+      || dataConUserTyVarsArePermuted data_con
+                     -- If the data type was written with GADT syntax and
+                     -- orders the type variables differently from what the
+                     -- worker expects, it needs a data con wrapper to reorder
+                     -- the type variables.
+                     -- See Note [Data con wrappers and GADT syntax].
 
     initial_wrap_app = Var (dataConWorkId data_con)
                        `mkTyApps`  res_ty_args
@@ -602,8 +673,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
     mk_boxer boxers = DCB (\ ty_args src_vars ->
                       do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars
                                subst1 = zipTvSubst univ_tvs ty_args
-                               subst2 = extendTvSubstList subst1 ex_tvs
-                                                          (mkTyVarTys ex_vars)
+                               subst2 = extendTCvSubstList subst1 ex_tvs
+                                                           (mkTyCoVarTys ex_vars)
                          ; (rep_ids, binds) <- go subst2 boxers term_vars
                          ; return (ex_vars ++ rep_ids, binds) } )
 
@@ -669,6 +740,40 @@ For a start, it's still to generate a no-op.  But worse, since wrappers
 are currently injected at TidyCore, we don't even optimise it away!
 So the stupid case expression stays there.  This actually happened for
 the Integer data type (see Trac #1600 comment:66)!
+
+Note [Data con wrappers and GADT syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these two very similar data types:
+
+  data T1 a b = MkT1 b
+
+  data T2 a b where
+    MkT2 :: forall b a. b -> T2 a b
+
+Despite their similar appearance, T2 will have a data con wrapper but T1 will
+not. What sets them apart? The types of their constructors, which are:
+
+  MkT1 :: forall a b. b -> T1 a b
+  MkT2 :: forall b a. b -> T2 a b
+
+MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
+would normally appear. See Note [DataCon user type variable binders] in DataCon
+for further discussion on this topic.
+
+The worker data cons for T1 and T2, however, both have types such that `a` is
+expected to come before `b` as arguments. Because MkT2 permutes this order, it
+needs a data con wrapper to swizzle around the type variables to be in the
+order the worker expects.
+
+A somewhat surprising consequence of this is that *newtypes* can have data con
+wrappers! After all, a newtype can also be written with GADT syntax:
+
+  newtype T3 a b where
+    MkT3 :: forall b a. b -> T3 a b
+
+Again, this needs a wrapper data con to reorder the type variables. It does
+mean that this newtype constructor requires another level of indirection when
+being called, but the inliner should make swift work of that.
 -}
 
 -------------------------
@@ -788,7 +893,8 @@ dataConArgUnpack arg_ty
       -- A recursive newtype might mean that
       -- 'arg_ty' is a newtype
   , let rep_tys = dataConInstArgTys con tc_args
-  = ASSERT( isVanillaDataCon con )
+  = ASSERT( null (dataConExTyCoVars con) )
+      -- Note [Unpacking GADTs and existentials]
     ( rep_tys `zip` dataConRepStrictness con
     ,( \ arg_id ->
        do { rep_ids <- mapM newLocal rep_tys
@@ -812,31 +918,33 @@ isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
 -- we encounter on the way, because otherwise we might well
 -- end up relying on ourselves!
 isUnpackableType dflags fam_envs ty
-  | Just (tc, _) <- splitTyConApp_maybe ty
-  , Just con <- tyConSingleAlgDataCon_maybe tc
-  , isVanillaDataCon con
-  = ok_con_args (unitNameSet (getName tc)) con
+  | Just data_con <- unpackable_type ty
+  = ok_con_args emptyNameSet data_con
   | otherwise
   = False
   where
-    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
-        where
-          norm_ty = topNormaliseType fam_envs ty
-    ok_ty tcs ty
-      | Just (tc, _) <- splitTyConApp_maybe ty
-      , let tc_name = getName tc
-      =  not (tc_name `elemNameSet` tcs)
-      && case tyConSingleAlgDataCon_maybe tc of
-            Just con | isVanillaDataCon con
-                    -> ok_con_args (tcs `extendNameSet` getName tc) con
-            _ -> True
+    ok_con_args dcs con
+       | dc_name `elemNameSet` dcs
+       = False
+       | otherwise
+       = all (ok_arg dcs')
+             (dataConOrigArgTys con `zip` dataConSrcBangs con)
+          -- NB: dataConSrcBangs gives the *user* request;
+          -- We'd get a black hole if we used dataConImplBangs
+       where
+         dc_name = getName con
+         dcs' = dcs `extendNameSet` dc_name
+
+    ok_arg dcs (ty, bang)
+      = not (attempt_unpack bang) || ok_ty dcs norm_ty
+      where
+        norm_ty = topNormaliseType fam_envs ty
+
+    ok_ty dcs ty
+      | Just data_con <- unpackable_type ty
+      = ok_con_args dcs data_con
       | otherwise
-      = True
-
-    ok_con_args tcs con
-       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
-         -- NB: dataConSrcBangs gives the *user* request;
-         -- We'd get a black hole if we used dataConImplBangs
+      = True        -- NB True here, in contrast to False at top level
 
     attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
       = xopt LangExt.StrictData dflags
@@ -848,7 +956,31 @@ isUnpackableType dflags fam_envs ty
       = xopt LangExt.StrictData dflags -- Be conservative
     attempt_unpack _ = False
 
+    unpackable_type :: Type -> Maybe DataCon
+    -- Works just on a single level
+    unpackable_type ty
+      | Just (tc, _) <- splitTyConApp_maybe ty
+      , Just data_con <- tyConSingleAlgDataCon_maybe tc
+      , null (dataConExTyCoVars data_con)
+          -- See Note [Unpacking GADTs and existentials]
+      = Just data_con
+      | otherwise
+      = Nothing
+
 {-
+Note [Unpacking GADTs and existentials]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is nothing stopping us unpacking a data type with equality
+components, like
+  data Equal a b where
+    Equal :: Equal a a
+
+And it'd be fine to unpack a product type with existential components
+too, but that would require a bit more plumbing, so currently we don't.
+
+So for now we require: null (dataConExTyCoVars data_con)
+See Trac #14978
+
 Note [Unpack one-wide fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The flag UnboxSmallStrictFields ensures that any field that can
@@ -920,15 +1052,9 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 --
 -- If a coercion constructor is provided in the newtype, then we use
 -- it, otherwise the wrap/unwrap are both no-ops
---
--- If the we are dealing with a newtype *instance*, we have a second coercion
--- identifying the family instance with the constructor of the newtype
--- instance.  This coercion is applied in any case (ie, composed with the
--- coercion constructor of the newtype or applied by itself).
 
 wrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
-    wrapFamInstBody tycon args $
     mkCast result_expr (mkSymCo co)
   where
     co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []
@@ -955,35 +1081,6 @@ wrapFamInstBody tycon args body
   | otherwise
   = body
 
--- Same as `wrapFamInstBody`, but for type family instances, which are
--- represented by a `CoAxiom`, and not a `TyCon`
-wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion]
-                    -> CoreExpr -> CoreExpr
-wrapTypeFamInstBody axiom ind args cos body
-  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos))
-
-wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion]
-                              -> CoreExpr -> CoreExpr
-wrapTypeUnbranchedFamInstBody axiom
-  = wrapTypeFamInstBody axiom 0
-
-unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-unwrapFamInstScrut tycon args scrut
-  | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only
-  | otherwise
-  = scrut
-
-unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion]
-                       -> CoreExpr -> CoreExpr
-unwrapTypeFamInstScrut axiom ind args cos scrut
-  = mkCast scrut (mkAxInstCo Representational axiom ind args cos)
-
-unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion]
-                                 -> CoreExpr -> CoreExpr
-unwrapTypeUnbranchedFamInstScrut axiom
-  = unwrapTypeFamInstScrut axiom 0
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1042,7 +1139,7 @@ mkFCallId dflags uniq fcall ty
            `setLevityInfoWithType` ty
 
     (bndrs, _) = tcSplitPiTys ty
-    arity      = count isAnonTyBinder bndrs
+    arity      = count isAnonTyCoBinder bndrs
     strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
     -- the call does not claim to be strict in its arguments, since they
     -- may be lifted (foreign import prim) and the called code doesn't
@@ -1107,36 +1204,23 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 -}
 
-lazyIdName, unsafeCoerceName, nullAddrName, seqName,
+unsafeCoerceName, nullAddrName, seqName,
    realWorldName, voidPrimIdName, coercionTokenName,
-   magicDictName, coerceName, proxyName, dollarName, oneShotName,
-   runRWName, noinlineIdName :: Name
+   magicDictName, coerceName, proxyName :: Name
 unsafeCoerceName  = mkWiredInIdName gHC_PRIM  (fsLit "unsafeCoerce#")  unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId
 seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId
 realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId
 voidPrimIdName    = mkWiredInIdName gHC_PRIM  (fsLit "void#")          voidPrimIdKey      voidPrimId
-lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId
 coercionTokenName = mkWiredInIdName gHC_PRIM  (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
 magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId
 coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId
 proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId
-dollarName        = mkWiredInIdName gHC_BASE  (fsLit "$")              dollarIdKey        dollarId
-oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId
-runRWName         = mkWiredInIdName gHC_MAGIC (fsLit "runRW#")         runRWKey           runRWId
-noinlineIdName    = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId
 
-dollarId :: Id  -- Note [dollarId magic]
-dollarId = pcMiscPrelId dollarName ty
-             (noCafIdInfo `setUnfoldingInfo` unf)
-  where
-    fun_ty = mkFunTy alphaTy openBetaTy
-    ty     = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $
-             mkFunTy fun_ty fun_ty
-    unf    = mkInlineUnfoldingWithArity 2 rhs
-    [f,x]  = mkTemplateLocals [fun_ty, alphaTy]
-    rhs    = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $
-             App (Var f) (Var x)
+lazyIdName, oneShotName, noinlineIdName :: Name
+lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId
+oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId
+noinlineIdName    = mkWiredInIdName gHC_MAGIC (fsLit "noinline")       noinlineIdKey      noinlineId
 
 ------------------------------------------------
 proxyHashId :: Id
@@ -1228,33 +1312,12 @@ oneShotId = pcMiscPrelId oneShotName ty info
                           (mkFunTy fun_ty fun_ty)
     fun_ty = mkFunTy openAlphaTy openBetaTy
     [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
-    x' = setOneShotLambda x
+    x' = setOneShotLambda x  -- Here is the magic bit!
     rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
                  , openAlphaTyVar, openBetaTyVar
                  , body, x'] $
           Var body `App` Var x
 
-runRWId :: Id -- See Note [runRW magic] in this module
-runRWId = pcMiscPrelId runRWName ty info
-  where
-    info = noCafIdInfo `setInlinePragInfo` neverInlinePragma
-                       `setStrictnessInfo` strict_sig
-                       `setArityInfo`      1
-    strict_sig = mkClosedStrictSig [strictApply1Dmd] topRes
-      -- Important to express its strictness,
-      -- since it is not inlined until CorePrep
-      -- Also see Note [runRW arg] in CorePrep
-
-    -- State# RealWorld
-    stateRW = mkTyConApp statePrimTyCon [realWorldTy]
-    -- o
-    ret_ty  = openAlphaTy
-    -- State# RealWorld -> o
-    arg_ty  = stateRW `mkFunTy` ret_ty
-    -- (State# RealWorld -> o) -> o
-    ty      = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $
-              arg_ty `mkFunTy` ret_ty
-
 --------------------------------------------------------------------------------
 magicDictId :: Id  -- See Note [magicDictId magic]
 magicDictId = pcMiscPrelId magicDictName ty info
@@ -1285,20 +1348,6 @@ coerceId = pcMiscPrelId coerceName ty info
           [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]
 
 {-
-Note [dollarId magic]
-~~~~~~~~~~~~~~~~~~~~~
-The only reason that ($) is wired in is so that its type can be
-    forall (a:*, b:Open). (a->b) -> a -> b
-That is, the return type can be unboxed.  E.g. this is OK
-    foo $ True    where  foo :: Bool -> Int#
-because ($) doesn't inspect or move the result of the call to foo.
-See Trac #8739.
-
-There is a special typing rule for ($) in TcExpr, so the type of ($)
-isn't looked at there, BUT Lint subsequently (and rightly) complains
-if sees ($) applied to Int# (say), unless we give it a wired-in type
-as we do here.
-
 Note [Unsafe coerce magic]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 We define a *primitive*
@@ -1419,48 +1468,8 @@ a little bit of magic to optimize away 'noinline' after we are done
 running the simplifier.
 
 'noinline' needs to be wired-in because it gets inserted automatically
-when we serialize an expression to the interface format, and we DON'T
-want use its fingerprints.
-
-
-Note [runRW magic]
-~~~~~~~~~~~~~~~~~~
-Some definitions, for instance @runST@, must have careful control over float out
-of the bindings in their body. Consider this use of @runST@,
-
-    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
-                             (_, s'') = fill_in_array_or_something a x s'
-                         in freezeArray# a s'' )
-
-If we inline @runST@, we'll get:
-
-    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
-              (_, s'') = fill_in_array_or_something a x s'
-          in freezeArray# a s''
-
-And now if we allow the @newArray#@ binding to float out to become a CAF,
-we end up with a result that is totally and utterly wrong:
-
-    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
-        in \ x ->
-            let (_, s'') = fill_in_array_or_something a x s'
-            in freezeArray# a s''
-
-All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
-must be prevented.
-
-This is what @runRW#@ gives us: by being inlined extremely late in the
-optimization (right before lowering to STG, in CorePrep), we can ensure that
-no further floating will occur. This allows us to safely inline things like
-@runST@, which are otherwise needlessly expensive (see #10678 and #5916).
-
-While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@
-to be open-kinded,
-
-    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
-           => (State# RealWorld -> (# State# RealWorld, o #))
-                              -> (# State# RealWorld, o #)
-
+when we serialize an expression to the interface format. See
+Note [Inlining and hs-boot files] in ToIface
 
 Note [The oneShot function]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1469,11 +1478,11 @@ and Note [Left folds via right fold]) it was determined that it would be useful
 if library authors could explicitly tell the compiler that a certain lambda is
 called at most once. The oneShot function allows that.
 
-'oneShot' is open kinded, i.e. the type variables can refer to unlifted
+'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted
 types as well (Trac #10744); e.g.
    oneShot (\x:Int# -> x +# 1#)
 
-Like most magic functions it has a compulsary unfolding, so there is no need
+Like most magic functions it has a compulsory unfolding, so there is no need
 for a real definition somewhere. We have one in GHC.Magic for the convenience
 of putting the documentation there.
 
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index ab1f391e04..1851496af1 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -78,8 +78,6 @@ module Module
         baseUnitId,
         rtsUnitId,
         thUnitId,
-        dphSeqUnitId,
-        dphParUnitId,
         mainUnitId,
         thisGhcUnitId,
         isHoleModule,
@@ -137,6 +135,8 @@ module Module
         unitModuleSet
     ) where
 
+import GhcPrelude
+
 import Config
 import Outputable
 import Unique
@@ -149,13 +149,10 @@ import Util
 import Data.List
 import Data.Ord
 import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))
+import Fingerprint
 
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Unsafe as BS
 import qualified Data.ByteString.Char8 as BS.Char8
-import System.IO.Unsafe
-import Foreign.Ptr (castPtr)
-import GHC.Fingerprint
 import Encoding
 
 import qualified Text.ParserCombinators.ReadP as Parse
@@ -549,7 +546,6 @@ instance Outputable ComponentId where
 data UnitId
     = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId
     |   DefiniteUnitId {-# UNPACK #-} !DefUnitId
-    deriving (Typeable)
 
 unitIdFS :: UnitId -> FastString
 unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x
@@ -587,7 +583,7 @@ data IndefUnitId
         -- fully instantiated (free module variables are empty)
         -- and whether or not a substitution can have any effect.
         indefUnitIdFreeHoles :: UniqDSet ModuleName
-    } deriving (Typeable)
+    }
 
 instance Eq IndefUnitId where
   u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2
@@ -642,7 +638,7 @@ indefUnitIdToUnitId dflags iuid =
 data IndefModule = IndefModule {
         indefModuleUnitId :: IndefUnitId,
         indefModuleName   :: ModuleName
-    } deriving (Typeable, Eq, Ord)
+    } deriving (Eq, Ord)
 
 instance Outputable IndefModule where
   ppr (IndefModule uid m) =
@@ -670,7 +666,6 @@ newtype InstalledUnitId =
       -- and the hash.
       installedUnitIdFS :: FastString
     }
-   deriving (Typeable)
 
 instance Binary InstalledUnitId where
   put_ bh (InstalledUnitId fs) = put_ bh fs
@@ -761,7 +756,7 @@ installedUnitIdEq iuid uid =
 -- it only refers to a definite library; i.e., one we have generated
 -- code for.
 newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId }
-    deriving (Eq, Ord, Typeable)
+    deriving (Eq, Ord)
 
 instance Outputable DefUnitId where
     ppr (DefUnitId uid) = ppr uid
@@ -847,11 +842,6 @@ rawHashUnitId sorted_holes =
           fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
           toStringRep (moduleName b),   BS.Char8.singleton '\n']
 
-fingerprintByteString :: BS.ByteString -> Fingerprint
-fingerprintByteString bs = unsafePerformIO
-                         . BS.unsafeUseAsCStringLen bs
-                         $ \(p,l) -> fingerprintData (castPtr p) l
-
 fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
 fingerprintUnitId prefix (Fingerprint a b)
     = BS.concat
@@ -1075,8 +1065,7 @@ parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
 
 integerUnitId, primUnitId,
   baseUnitId, rtsUnitId,
-  thUnitId, dphSeqUnitId, dphParUnitId,
-  mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId
+  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId
 primUnitId        = fsToUnitId (fsLit "ghc-prim")
 integerUnitId     = fsToUnitId (fsLit n)
   where
@@ -1086,8 +1075,6 @@ integerUnitId     = fsToUnitId (fsLit n)
 baseUnitId        = fsToUnitId (fsLit "base")
 rtsUnitId         = fsToUnitId (fsLit "rts")
 thUnitId          = fsToUnitId (fsLit "template-haskell")
-dphSeqUnitId      = fsToUnitId (fsLit "dph-seq")
-dphParUnitId      = fsToUnitId (fsLit "dph-par")
 thisGhcUnitId     = fsToUnitId (fsLit "ghc")
 interactiveUnitId = fsToUnitId (fsLit "interactive")
 
@@ -1135,9 +1122,7 @@ wiredInUnitIds = [ primUnitId,
                        baseUnitId,
                        rtsUnitId,
                        thUnitId,
-                       thisGhcUnitId,
-                       dphSeqUnitId,
-                       dphParUnitId ]
+                       thisGhcUnitId ]
 
 {-
 ************************************************************************
diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot
index 734855a880..36e8abf997 100644
--- a/compiler/basicTypes/Module.hs-boot
+++ b/compiler/basicTypes/Module.hs-boot
@@ -1,4 +1,6 @@
 module Module where
+
+import GhcPrelude
 import FastString
 
 data Module
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index 45275e3eff..d9eacd9af6 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -51,7 +51,6 @@ module Name (
         setNameLoc,
         tidyNameOcc,
         localiseName,
-        mkLocalisedOccName,
 
         nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
 
@@ -70,15 +69,16 @@ module Name (
         NamedThing(..),
         getSrcLoc, getSrcSpan, getOccString, getOccFS,
 
-        pprInfixName, pprPrefixName, pprModulePrefix,
+        pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified,
         nameStableString,
 
         -- Re-export the OccName stuff
         module OccName
     ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TyCoRep( TyThing )
-import {-# SOURCE #-} PrelNames( starKindTyConKey, unicodeStarKindTyConKey )
 
 import OccName
 import Module
@@ -107,7 +107,7 @@ import Data.Data
 data Name = Name {
                 n_sort :: NameSort,     -- What sort of name it is
                 n_occ  :: !OccName,     -- Its occurrence name
-                n_uniq :: {-# UNPACK #-} !Int,
+                n_uniq :: {-# UNPACK #-} !Unique,
                 n_loc  :: !SrcSpan      -- Definition site
             }
 
@@ -115,6 +115,7 @@ data Name = Name {
 -- (and real!) space leaks, due to the fact that we don't look at
 -- the SrcLoc in a Name all that often.
 
+-- See Note [About the NameSorts]
 data NameSort
   = External Module
 
@@ -151,7 +152,7 @@ instance NFData NameSort where
 data BuiltInSyntax = BuiltInSyntax | UserSyntax
 
 {-
-Notes about the NameSorts:
+Note [About the NameSorts]
 
 1.  Initially, top-level Ids (including locally-defined ones) get External names,
     and all other local Ids get Internal names
@@ -192,11 +193,11 @@ instance HasOccName Name where
 
 nameUnique              :: Name -> Unique
 nameOccName             :: Name -> OccName
-nameModule              :: Name -> Module
+nameModule              :: HasDebugCallStack => Name -> Module
 nameSrcLoc              :: Name -> SrcLoc
 nameSrcSpan             :: Name -> SrcSpan
 
-nameUnique  name = mkUniqueGrimily (n_uniq name)
+nameUnique  name = n_uniq name
 nameOccName name = n_occ  name
 nameSrcLoc  name = srcSpanStart (n_loc name)
 nameSrcSpan name = n_loc  name
@@ -260,7 +261,7 @@ nameIsLocalOrFrom :: Module -> Name -> Bool
 --                 you can find details (type, fixity, instances) in the
 --                     TcGblEnv or TcLclEnv
 --
--- The isInteractiveModule part is because successive interactions of a GCHi session
+-- The isInteractiveModule part is because successive interactions of a GHCi session
 -- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come
 -- from the magic 'interactive' package; and all the details are kept in the
 -- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.
@@ -293,7 +294,7 @@ nameIsHomePackageImport this_mod
     this_pkg = moduleUnitId this_mod
 
 -- | Returns True if the Name comes from some other package: neither this
--- pacakge nor the interactive package.
+-- package nor the interactive package.
 nameIsFromExternalPackage :: UnitId -> Name -> Bool
 nameIsFromExternalPackage this_pkg name
   | Just mod <- nameModule_maybe name
@@ -332,7 +333,7 @@ isSystemName _                        = False
 -- | Create a name which is (for now at least) local to the current module and hence
 -- does not need a 'Module' to disambiguate it from other 'Name's
 mkInternalName :: Unique -> OccName -> SrcSpan -> Name
-mkInternalName uniq occ loc = Name { n_uniq = getKey uniq
+mkInternalName uniq occ loc = Name { n_uniq = uniq
                                    , n_sort = Internal
                                    , n_occ = occ
                                    , n_loc = loc }
@@ -347,12 +348,12 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey uniq
 
 mkClonedInternalName :: Unique -> Name -> Name
 mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
-  = Name { n_uniq = getKey uniq, n_sort = Internal
+  = Name { n_uniq = uniq, n_sort = Internal
          , n_occ = occ, n_loc = loc }
 
 mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
 mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
-  = Name { n_uniq = getKey uniq, n_sort = Internal
+  = Name { n_uniq = uniq, n_sort = Internal
          , n_occ = derive_occ occ, n_loc = loc }
 
 -- | Create a name which definitely originates in the given module
@@ -361,13 +362,13 @@ mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
 -- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName
 -- with some fresh unique without populating the Name Cache
 mkExternalName uniq mod occ loc
-  = Name { n_uniq = getKey uniq, n_sort = External mod,
+  = Name { n_uniq = uniq, n_sort = External mod,
            n_occ = occ, n_loc = loc }
 
 -- | Create a name which is actually defined by the compiler itself
 mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
 mkWiredInName mod occ uniq thing built_in
-  = Name { n_uniq = getKey uniq,
+  = Name { n_uniq = uniq,
            n_sort = WiredIn mod thing built_in,
            n_occ = occ, n_loc = wiredInSrcSpan }
 
@@ -376,14 +377,14 @@ mkSystemName :: Unique -> OccName -> Name
 mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan
 
 mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name
-mkSystemNameAt uniq occ loc = Name { n_uniq = getKey uniq, n_sort = System
+mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System
                                    , n_occ = occ, n_loc = loc }
 
 mkSystemVarName :: Unique -> FastString -> Name
 mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
 
 mkSysTvName :: Unique -> FastString -> Name
-mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)
+mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs)
 
 -- | Make a name for a foreign call
 mkFCallName :: Unique -> String -> Name
@@ -394,7 +395,7 @@ mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan
 -- able to change a Name's Unique to match the cached
 -- one in the thing it's the name of.  If you know what I mean.
 setNameUnique :: Name -> Unique -> Name
-setNameUnique name uniq = name {n_uniq = getKey uniq}
+setNameUnique name uniq = name {n_uniq = uniq}
 
 -- This is used for hsigs: we want to use the name of the originally exported
 -- entity, but edit the location to refer to the reexport site
@@ -412,18 +413,6 @@ tidyNameOcc name                            occ = name { n_occ = occ }
 localiseName :: Name -> Name
 localiseName n = n { n_sort = Internal }
 
--- |Create a localised variant of a name.
---
--- If the name is external, encode the original's module name to disambiguate.
--- SPJ says: this looks like a rather odd-looking function; but it seems to
---           be used only during vectorisation, so I'm not going to worry
-mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
-mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
-  where
-    origin
-      | nameIsLocalOrFrom this_mod name = Nothing
-      | otherwise                       = Just (moduleNameColons . moduleName . nameModule $ name)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -433,7 +422,7 @@ mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
 -}
 
 cmpName :: Name -> Name -> Ordering
-cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2
+cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2
 
 -- | Compare Names lexicographically
 -- This only works for Names that originate in the source code or have been
@@ -465,10 +454,18 @@ stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
 ************************************************************************
 -}
 
+-- | The same comments as for `Name`'s `Ord` instance apply.
 instance Eq Name where
     a == b = case (a `compare` b) of { EQ -> True;  _ -> False }
     a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
 
+-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which
+-- means that the ordering is not stable across deserialization or rebuilds.
+--
+-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug
+-- caused by improper use of this instance.
+
+-- For a deterministic lexicographic ordering, use `stableNameCmp`.
 instance Ord Name where
     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
@@ -525,14 +522,17 @@ instance OutputableBndr Name where
     pprPrefixOcc = pprPrefixName
 
 pprName :: Name -> SDoc
-pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
+pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
   = getPprStyle $ \ sty ->
     case sort of
       WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin
       External mod            -> pprExternal sty uniq mod occ False UserSyntax
       System                  -> pprSystem sty uniq occ
       Internal                -> pprInternal sty uniq occ
-  where uniq = mkUniqueGrimily u
+
+-- | Print the string of Name unqualifiedly directly.
+pprNameUnqualified :: Name -> SDoc
+pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
 
 pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
 pprExternal sty uniq mod occ is_wired is_builtin
@@ -687,24 +687,6 @@ pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc
 pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
 
 pprPrefixName :: NamedThing a => a -> SDoc
-pprPrefixName thing
- | name `hasKey` starKindTyConKey || name `hasKey` unicodeStarKindTyConKey
- = ppr name   -- See Note [Special treatment for kind *]
- | otherwise
- = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
+pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
  where
    name = getName thing
-
-{-
-Note [Special treatment for kind *]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do not put parens around the kind '*'.  Even though it looks like
-an operator, it is really a special case.
-
-This pprPrefixName stuff is really only used when printing HsSyn,
-which has to be polymorphic in the name type, and hence has to go via
-the overloaded function pprPrefixOcc.  It's easier where we know the
-type being pretty printed; eg the pretty-printing code in TyCoRep.
-
-See Trac #7645, which led to this.
--}
diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot
index c4eeca4d68..54efe686ad 100644
--- a/compiler/basicTypes/Name.hs-boot
+++ b/compiler/basicTypes/Name.hs-boot
@@ -1,3 +1,5 @@
 module Name where
 
+import GhcPrelude ()
+
 data Name
diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs
index 589c7c4e3b..13fb1f57fe 100644
--- a/compiler/basicTypes/NameCache.hs
+++ b/compiler/basicTypes/NameCache.hs
@@ -10,6 +10,8 @@ module NameCache
     , NameCache(..), OrigNameCache
     ) where
 
+import GhcPrelude
+
 import Module
 import Name
 import UniqSupply
@@ -115,4 +117,4 @@ initNameCache us names
                 nsNames = initOrigNames names }
 
 initOrigNames :: [Name] -> OrigNameCache
-initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
+initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names
diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs
index cca771a33e..632ea7742e 100644
--- a/compiler/basicTypes/NameEnv.hs
+++ b/compiler/basicTypes/NameEnv.hs
@@ -33,6 +33,8 @@ module NameEnv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Digraph
 import Name
 import UniqFM
diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs
index 57de81cb44..76b6626589 100644
--- a/compiler/basicTypes/NameSet.hs
+++ b/compiler/basicTypes/NameSet.hs
@@ -33,6 +33,8 @@ module NameSet (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Name
 import UniqSet
 import Data.List (sortBy)
@@ -79,7 +81,7 @@ delFromNameSet    = delOneFromUniqSet
 filterNameSet     = filterUniqSet
 intersectNameSet  = intersectUniqSets
 
-delListFromNameSet set ns = foldl delFromNameSet set ns
+delListFromNameSet set ns = foldl' delFromNameSet set ns
 
 intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
 
diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index 0fa2749ba1..c3ee937baa 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -67,11 +67,6 @@ module OccName (
         mkSuperDictSelOcc, mkSuperDictAuxOcc,
         mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
         mkInstTyCoOcc, mkEqPredCoOcc,
-        mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
-        mkPDataTyConOcc,  mkPDataDataConOcc,
-        mkPDatasTyConOcc, mkPDatasDataConOcc,
-        mkPReprTyConOcc,
-        mkPADFunOcc,
         mkRecFldSelOcc,
         mkTyConRepOcc,
 
@@ -105,6 +100,8 @@ module OccName (
         FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
     ) where
 
+import GhcPrelude
+
 import Util
 import Unique
 import DynFlags
@@ -653,23 +650,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
 mkGenR   = mk_simple_deriv tcName "Rep_"
 mkGen1R  = mk_simple_deriv tcName "Rep1_"
 
--- Vectorisation
-mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
- mkPADFunOcc,      mkPReprTyConOcc,
- mkPDataTyConOcc,  mkPDataDataConOcc,
- mkPDatasTyConOcc, mkPDatasDataConOcc
-  :: Maybe String -> OccName -> OccName
-mkVectOcc          = mk_simple_deriv_with varName  "$v"
-mkVectTyConOcc     = mk_simple_deriv_with tcName   "V:"
-mkVectDataConOcc   = mk_simple_deriv_with dataName "VD:"
-mkVectIsoOcc       = mk_simple_deriv_with varName  "$vi"
-mkPADFunOcc        = mk_simple_deriv_with varName  "$pa"
-mkPReprTyConOcc    = mk_simple_deriv_with tcName   "VR:"
-mkPDataTyConOcc    = mk_simple_deriv_with tcName   "VP:"
-mkPDatasTyConOcc   = mk_simple_deriv_with tcName   "VPs:"
-mkPDataDataConOcc  = mk_simple_deriv_with dataName "VPD:"
-mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"
-
 -- Overloaded record field selectors
 mkRecFldSelOcc :: String -> OccName
 mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
@@ -677,15 +657,6 @@ mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
 mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName
 mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]
 
-mk_simple_deriv_with :: NameSpace     -- ^ the namespace
-                     -> FastString    -- ^ an identifying prefix
-                     -> Maybe String  -- ^ another optional prefix
-                     -> OccName       -- ^ the 'OccName' to derive from
-                     -> OccName
-mk_simple_deriv_with sp px Nothing     occ = mk_deriv sp px [occNameFS occ]
-mk_simple_deriv_with sp px (Just with) occ =
-    mk_deriv sp px [fsLit with, fsLit "_", occNameFS occ]
-
 -- Data constructor workers are made by setting the name space
 -- of the data constructor OccName (which should be a DataName)
 -- to VarName
@@ -871,7 +842,7 @@ emptyTidyOccEnv :: TidyOccEnv
 emptyTidyOccEnv = emptyUFM
 
 initTidyOccEnv :: [OccName] -> TidyOccEnv       -- Initialise with names to avoid!
-initTidyOccEnv = foldl add emptyUFM
+initTidyOccEnv = foldl' add emptyUFM
   where
     add env (OccName _ fs) = addToUFM env fs 1
 
diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot
index c6fa8850cf..31d77a44a9 100644
--- a/compiler/basicTypes/OccName.hs-boot
+++ b/compiler/basicTypes/OccName.hs-boot
@@ -1,3 +1,5 @@
 module OccName where
 
+import GhcPrelude ()
+
 data OccName
diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 0e218a39c1..bf9426ecc8 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -24,6 +24,8 @@ module PatSyn (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Type
 import Name
 import Outputable
@@ -63,7 +65,7 @@ data PatSyn
                                        -- record pat syn or same length as
                                        -- psArgs
 
-        -- Universially-quantified type variables
+        -- Universally-quantified type variables
         psUnivTyVars  :: [TyVarBinder],
 
         -- Required dictionaries (may mention psUnivTyVars)
@@ -76,7 +78,8 @@ data PatSyn
         psProvTheta   :: ThetaType,
 
         -- Result type
-        psOrigResTy   :: Type,         -- Mentions only psUnivTyVars
+        psResultTy   :: Type,  -- Mentions only psUnivTyVars
+                               -- See Note [Pattern synonym result type]
 
         -- See Note [Matchers and builders for pattern synonyms]
         psMatcher     :: (Id, Bool),
@@ -145,6 +148,43 @@ Example 3:
    You can see it's existential because it doesn't appear in the
    result type (T3 b).
 
+Note [Pattern synonym result type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a b = MkT b a
+
+   pattern P :: a -> T [a] Bool
+   pattern P x = MkT True [x]
+
+P's psResultTy is (T a Bool), and it really only matches values of
+type (T [a] Bool).  For example, this is ill-typed
+
+   f :: T p q -> String
+   f (P x) = "urk"
+
+This is different to the situation with GADTs:
+
+   data S a where
+     MkS :: Int -> S Bool
+
+Now MkS (and pattern synonyms coming from MkS) can match a
+value of type (S a), not just (S Bool); we get type refinement.
+
+That in turn means that if you have a pattern
+
+   P x :: T [ty] Bool
+
+it's not entirely straightforward to work out the instantiation of
+P's universal tyvars. You have to /match/
+  the type of the pattern, (T [ty] Bool)
+against
+  the psResultTy for the pattern synonym, T [a] Bool
+to get the instantiation a := ty.
+
+This is very unlike DataCons, where univ tyvars match 1-1 the
+arguments of the TyCon.
+
+
 Note [Pattern synonym representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following pattern synonym declaration
@@ -174,7 +214,7 @@ In this case, the fields of MkPatSyn will be set as follows:
   psExTyVars   = [b]
   psProvTheta  = (Show (Maybe t), Ord b)
   psReqTheta   = (Eq t, Num t)
-  psOrigResTy  = T (Maybe t)
+  psResultTy  = T (Maybe t)
 
 Note [Matchers and builders for pattern synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -245,7 +285,7 @@ done by TcPatSyn.patSynBuilderOcc.
 Note [Pattern synonyms and the data type Type]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The type of a pattern synonym is of the form (See Note
-[Pattern synonym signatures]):
+[Pattern synonym signatures] in TcSigs):
 
     forall univ_tvs. req => forall ex_tvs. prov => ...
 
@@ -299,10 +339,10 @@ instance Data.Data PatSyn where
 -- | Build a new pattern synonym
 mkPatSyn :: Name
          -> Bool                 -- ^ Is the pattern synonym declared infix?
-         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables
-                                 --   and required dicts
-         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables
-                                 --   and provided dicts
+         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type
+                                       -- variables and required dicts
+         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type
+                                       -- variables and provided dicts
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
          -> (Id, Bool)           -- ^ Name of matcher
@@ -325,7 +365,7 @@ mkPatSyn name declared_infix
                 psInfix = declared_infix,
                 psArgs = orig_args,
                 psArity = length orig_args,
-                psOrigResTy = orig_res_ty,
+                psResultTy = orig_res_ty,
                 psMatcher = matcher,
                 psBuilder = builder,
                 psFieldLabels = field_labels
@@ -368,7 +408,7 @@ patSynExTyVarBinders = psExTyVars
 patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psProvTheta = prov, psReqTheta = req
-                    , psArgs = arg_tys, psOrigResTy = res_ty })
+                    , psArgs = arg_tys, psResultTy = res_ty })
   = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)
 
 patSynMatcher :: PatSyn -> (Id,Bool)
@@ -405,9 +445,9 @@ patSynInstResTy :: PatSyn -> [Type] -> Type
 -- E.g.  pattern P x y = Just (x,x,y)
 --         P :: a -> b -> Just (a,a,b)
 --         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
--- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
+-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars
 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
-                          , psOrigResTy = res_ty })
+                          , psResultTy = res_ty })
                 inst_tys
   = ASSERT2( univ_tvs `equalLength` inst_tys
            , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
@@ -417,7 +457,7 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
 pprPatSynType :: PatSyn -> SDoc
 pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta
                         , psExTyVars   = ex_tvs,    psProvTheta = prov_theta
-                        , psArgs       = orig_args, psOrigResTy = orig_res_ty })
+                        , psArgs       = orig_args, psResultTy = orig_res_ty })
   = sep [ pprForAll univ_tvs
         , pprThetaArrowTy req_theta
         , ppWhen insert_empty_ctxt $ parens empty <+> darrow
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 9e59c971d5..45f23249bc 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -34,8 +34,7 @@ module RdrName (
         -- ** Destruction
         rdrNameOcc, rdrNameSpace, demoteRdrName,
         isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,
-        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, isStar,
-        isUniStar,
+        isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
 
         -- * Local mapping of 'RdrName' to 'Name.Name'
         LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
@@ -48,6 +47,7 @@ module RdrName (
         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
         pprGlobalRdrEnv, globalRdrEnvElts,
         lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
+        lookupGRE_Name_OccName,
         getGRE_NameQualifier_maybes,
         transformGREs, pickGREs, pickGREsModExp,
 
@@ -62,11 +62,16 @@ module RdrName (
         pprNameProvenance,
         Parent(..),
         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
-        importSpecLoc, importSpecModule, isExplicitItem, bestImport
+        importSpecLoc, importSpecModule, isExplicitItem, bestImport,
+
+        -- * Utils for StarIsType
+        starInfo
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Module
 import Name
 import Avail
@@ -83,7 +88,7 @@ import Util
 import NameEnv
 
 import Data.Data
-import Data.List( sortBy, foldl', nub )
+import Data.List( sortBy, nub )
 
 {-
 ************************************************************************
@@ -109,7 +114,7 @@ import Data.List( sortBy, foldl', nub )
 --           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,
 --           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
 --           'ApiAnnotation.AnnBackquote' @'`'@,
---           'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',
+--           'ApiAnnotation.AnnVal'
 --           'ApiAnnotation.AnnTilde',
 
 -- For details on above see note [Api annotations] in ApiAnnotation
@@ -259,10 +264,6 @@ isExact_maybe :: RdrName -> Maybe Name
 isExact_maybe (Exact n) = Just n
 isExact_maybe _         = Nothing
 
-isStar, isUniStar :: RdrName -> Bool
-isStar     = (fsLit "*" ==) . occNameFS . rdrNameOcc
-isUniStar = (fsLit "★" ==) . occNameFS . rdrNameOcc
-
 {-
 ************************************************************************
 *                                                                      *
@@ -471,7 +472,7 @@ data Parent = NoParent
             | ParentIs  { par_is :: Name }
             | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }
               -- ^ See Note [Parents for record fields]
-            deriving (Eq, Data, Typeable)
+            deriving (Eq, Data)
 
 instance Outputable Parent where
    ppr NoParent        = empty
@@ -886,13 +887,13 @@ pickGREs returns two GRE
    gre1:   gre_lcl = True,  gre_imp = []
    gre2:   gre_lcl = False, gre_imp = [ imported from Bar ]
 
-Now the the "ambiguous occurrence" message can correctly report how the
+Now the "ambiguous occurrence" message can correctly report how the
 ambiguity arises.
 -}
 
 pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
 -- ^ Takes a list of GREs which have the right OccName 'x'
--- Pick those GREs that are are in scope
+-- Pick those GREs that are in scope
 --    * Qualified,   as 'M.x'  if want_qual    is Qual M _
 --    * Unqualified, as 'x'    if want_unqual  is Unqual _
 --
@@ -994,22 +995,51 @@ extendGlobalRdrEnv env gre
                      (greOccName gre) gre
 
 shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
-shadowNames = foldl shadowName
+shadowNames = foldl' shadowName
 
 {- Note [GlobalRdrEnv shadowing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Before adding new names to the GlobalRdrEnv we nuke some existing entries;
-this is "shadowing".  The actual work is done by RdrEnv.shadowNames.
+this is "shadowing".  The actual work is done by RdrEnv.shadowName.
+Suppose
+   env' = shadowName env M.f
+
+Then:
+   * Looking up (Unqual f) in env' should succeed, returning M.f,
+     even if env contains existing unqualified bindings for f.
+     They are shadowed
+
+   * Looking up (Qual M.f) in env' should succeed, returning M.f
+
+   * Looking up (Qual X.f) in env', where X /= M, should be the same as
+     looking up (Qual X.f) in env.
+     That is, shadowName does /not/ delete earlier qualified bindings
+
 There are two reasons for shadowing:
 
 * The GHCi REPL
 
   - Ids bought into scope on the command line (eg let x = True) have
     External Names, like Ghci4.x.  We want a new binding for 'x' (say)
-    to override the existing binding for 'x'.
-    See Note [Interactively-bound Ids in GHCi] in HscTypes
-
-  - Data types also have Extenal Names, like Ghci4.T; but we still want
+    to override the existing binding for 'x'.  Example:
+
+           ghci> :load M    -- Brings `x` and `M.x` into scope
+           ghci> x
+           ghci> "Hello"
+           ghci> M.x
+           ghci> "hello"
+           ghci> let x = True  -- Shadows `x`
+           ghci> x             -- The locally bound `x`
+                               -- NOT an ambiguous reference
+           ghci> True
+           ghci> M.x           -- M.x is still in scope!
+           ghci> "Hello"
+    So when we add `x = True` we must not delete the `M.x` from the
+    `GlobalRdrEnv`; rather we just want to make it "qualified only";
+    hence the `mk_fake-imp_spec` in `shadowName`.  See also Note
+    [Interactively-bound Ids in GHCi] in HscTypes
+
+  - Data types also have External Names, like Ghci4.T; but we still want
     'T' to mean the newly-declared 'T', not an old one.
 
 * Nested Template Haskell declaration brackets
@@ -1017,10 +1047,10 @@ There are two reasons for shadowing:
 
   Consider a TH decl quote:
       module M where
-        f x = h [d| f = 3 |]
-  We must shadow the outer declaration of 'f', else we'll get a
-  complaint when extending the GlobalRdrEnv, saying that there are two
-  bindings for 'f'.  There are several tricky points:
+        f x = h [d| f = ...f...M.f... |]
+  We must shadow the outer unqualified binding of 'f', else we'll get
+  a complaint when extending the GlobalRdrEnv, saying that there are
+  two bindings for 'f'.  There are several tricky points:
 
     - This shadowing applies even if the binding for 'f' is in a
       where-clause, and hence is in the *local* RdrEnv not the *global*
@@ -1208,9 +1238,8 @@ pprNameProvenance :: GlobalRdrElt -> SDoc
 -- ^ Print out one place where the name was define/imported
 -- (With -dppr-debug, print them all)
 pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
-  = sdocWithPprDebug $ \dbg -> if dbg
-      then vcat pp_provs
-      else head pp_provs
+  = ifPprDebug (vcat pp_provs)
+               (head pp_provs)
   where
     pp_provs = pp_lcl ++ map pp_is iss
     pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
@@ -1246,3 +1275,80 @@ instance Outputable ImportSpec where
 pprLoc :: SrcSpan -> SDoc
 pprLoc (RealSrcSpan s)    = text "at" <+> ppr s
 pprLoc (UnhelpfulSpan {}) = empty
+
+-- | Display info about the treatment of '*' under NoStarIsType.
+--
+-- With StarIsType, three properties of '*' hold:
+--
+--   (a) it is not an infix operator
+--   (b) it is always in scope
+--   (c) it is a synonym for Data.Kind.Type
+--
+-- However, the user might not know that he's working on a module with
+-- NoStarIsType and write code that still assumes (a), (b), and (c), which
+-- actually do not hold in that module.
+--
+-- Violation of (a) shows up in the parser. For instance, in the following
+-- examples, we have '*' not applied to enough arguments:
+--
+--   data A :: *
+--   data F :: * -> *
+--
+-- Violation of (b) or (c) show up in the renamer and the typechecker
+-- respectively. For instance:
+--
+--   type K = Either * Bool
+--
+-- This will parse differently depending on whether StarIsType is enabled,
+-- but it will parse nonetheless. With NoStarIsType it is parsed as a type
+-- operator, thus we have ((*) Either Bool). Now there are two cases to
+-- consider:
+--
+--   1. There is no definition of (*) in scope. In this case the renamer will
+--      fail to look it up. This is a violation of assumption (b).
+--
+--   2. There is a definition of the (*) type operator in scope (for example
+--      coming from GHC.TypeNats). In this case the user will get a kind
+--      mismatch error. This is a violation of assumption (c).
+--
+-- The user might unknowingly be working on a module with NoStarIsType
+-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a
+-- hint whenever an assumption about '*' is violated. Unfortunately, it is
+-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b).
+--
+-- 'starInfo' generates an appropriate hint to the user depending on the
+-- extensions enabled in the module and the name that triggered the error.
+-- That is, if we have NoStarIsType and the error is related to '*' or its
+-- Unicode variant, the resulting SDoc will contain a helpful suggestion.
+-- Otherwise it is empty.
+--
+starInfo :: Bool -> RdrName -> SDoc
+starInfo star_is_type rdr_name =
+  -- One might ask: if can use sdocWithDynFlags here, why bother to take
+  -- star_is_type as input? Why not refactor?
+  --
+  -- The reason is that sdocWithDynFlags would provide DynFlags that are active
+  -- in the module that tries to load the problematic definition, not
+  -- in the module that is being loaded.
+  --
+  -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint
+  -- must be displayed even if we load this definition from a module (or GHCi)
+  -- with StarIsType enabled!
+  --
+  if isUnqualStar && not star_is_type
+     then text "With NoStarIsType, " <>
+          quotes (ppr rdr_name) <>
+          text " is treated as a regular type operator. "
+        $$
+          text "Did you mean to use " <> quotes (text "Type") <>
+          text " from Data.Kind instead?"
+      else empty
+  where
+    -- Does rdr_name look like the user might have meant the '*' kind by it?
+    -- We focus on unqualified stars specifically, because qualified stars are
+    -- treated as type operators even under StarIsType.
+    isUnqualStar
+      | Unqual occName <- rdr_name
+      = let fs = occNameFS occName
+        in fs == fsLit "*" || fs == fsLit "★"
+      | otherwise = False
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index f71dac6273..3276f41f14 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -7,10 +7,6 @@
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE RecordWildCards    #-}
-{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-   -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
-   -- When the earliest compiler we want to boostrap with is
-   -- GHC 7.2, we can make RealSrcLoc properly abstract
 
 -- | This module contains types that relate to the positions of things
 -- in source files, and allow tagging of those things with locations
@@ -81,6 +77,8 @@ module SrcLoc (
         spans, isSubspanOf, sortLocated
     ) where
 
+import GhcPrelude
+
 import Util
 import Json
 import Outputable
@@ -309,12 +307,14 @@ mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
     = RealSrcSpan (mkRealSrcSpan loc1 loc2)
 
 -- | Combines two 'SrcSpan' into one that spans at least all the characters
--- within both spans. Assumes the "file" part is the same in both inputs
+-- within both spans. Returns UnhelpfulSpan if the files differ.
 combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
 combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
 combineSrcSpans l (UnhelpfulSpan _) = l
 combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
-    = RealSrcSpan (combineRealSrcSpans span1 span2)
+  | srcSpanFile span1 == srcSpanFile span2
+      = RealSrcSpan (combineRealSrcSpans span1 span2)
+  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
 
 -- | Combines two 'SrcSpan' into one that spans at least all the characters
 -- within both spans. Assumes the "file" part is the same in both inputs
@@ -335,6 +335,7 @@ srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
   where
     loc1@(SrcLoc f l c) = realSrcSpanStart span
     loc2 = SrcLoc f l (c+1)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -513,8 +514,8 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
 data GenLocated l e = L l e
   deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
 
-type Located e = GenLocated SrcSpan e
-type RealLocated e = GenLocated RealSrcSpan e
+type Located = GenLocated SrcSpan
+type RealLocated = GenLocated RealSrcSpan
 
 unLoc :: GenLocated l e -> e
 unLoc (L _ e) = e
@@ -552,7 +553,7 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
                 -- GenLocated:
                 -- Print spans without the file name etc
                 -- ifPprDebug (braces (pprUserSpan False l))
-                ifPprDebug (braces (ppr l))
+                whenPprDebug (braces (ppr l))
              $$ ppr e
 
 {-
diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index da1a924736..664600147e 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -29,7 +29,10 @@ module UniqSupply (
         initUniqSupply
   ) where
 
+import GhcPrelude
+
 import Unique
+import Panic (panic)
 
 import GHC.IO
 
@@ -37,6 +40,7 @@ import MonadUtils
 import Control.Monad
 import Data.Bits
 import Data.Char
+import Control.Monad.Fail
 
 #include "Unique.h"
 
@@ -145,6 +149,10 @@ instance Applicative UniqSM where
                               (# xx, us'' #) -> (# ff xx, us'' #)
     (*>) = thenUs_
 
+-- TODO: try to get rid of this instance
+instance MonadFail UniqSM where
+    fail = panic
+
 -- | Run the 'UniqSM' action, returning the final 'UniqSupply'
 initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
 initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index a49fa80946..b5c0fcec58 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -32,10 +32,12 @@ module Unique (
         mkUniqueGrimily,                -- Used in UniqSupply only!
         getKey,                         -- Used in Var, UniqFM, Name only!
         mkUnique, unpkUnique,           -- Used in BinIface only
+        eqUnique, ltUnique,
 
         deriveUnique,                   -- Ditto
         newTagUnique,                   -- Used in CgCase
         initTyVarUnique,
+        initExitJoinUnique,
         nonDetCmpUnique,
         isValidKnownKeyUnique,          -- Used in PrelInfo.knownKeyNamesOkay
 
@@ -47,7 +49,7 @@ module Unique (
         mkPrimOpIdUnique,
         mkPreludeMiscIdUnique, mkPreludeDataConUnique,
         mkPreludeTyConUnique, mkPreludeClassUnique,
-        mkPArrDataConUnique, mkCoVarUnique,
+        mkCoVarUnique,
 
         mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
         mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
@@ -62,12 +64,14 @@ module Unique (
         -- *** From TyCon name uniques
         tyConRepNameUnique,
         -- *** From DataCon name uniques
-        dataConWorkerUnique, dataConRepNameUnique
+        dataConWorkerUnique, dataConTyRepNameUnique
     ) where
 
 #include "HsVersions.h"
 #include "Unique.h"
 
+import GhcPrelude
+
 import BasicTypes
 import FastString
 import Outputable
@@ -237,6 +241,9 @@ use `deriving' because we want {\em precise} control of ordering
 eqUnique :: Unique -> Unique -> Bool
 eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
 
+ltUnique :: Unique -> Unique -> Bool
+ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2
+
 -- Provided here to make it explicit at the call-site that it can
 -- introduce non-determinism.
 -- See Note [Unique Determinism]
@@ -318,7 +325,7 @@ iToBase62 n_
     go n cs | n < 62
             = let !c = chooseChar62 n in c : cs
             | otherwise
-            = go q (c : cs) where (q, r) = quotRem n 62
+            = go q (c : cs) where (!q, r) = quotRem n 62
                                   !c = chooseChar62 r
 
     chooseChar62 :: Int -> Char
@@ -362,7 +369,6 @@ mkPreludeTyConUnique   :: Int -> Unique
 mkPreludeDataConUnique :: Arity -> Unique
 mkPrimOpIdUnique       :: Int -> Unique
 mkPreludeMiscIdUnique  :: Int -> Unique
-mkPArrDataConUnique    :: Int -> Unique
 mkCoVarUnique          :: Int -> Unique
 
 mkAlphaTyVarUnique   i = mkUnique '1' i
@@ -394,17 +400,14 @@ tyConRepNameUnique  u = incrUnique u
 mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic
 
 --------------------------------------------------
-dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
 dataConWorkerUnique  u = incrUnique u
-dataConRepNameUnique u = stepUnique u 2
+dataConTyRepNameUnique u = stepUnique u 2
 
 --------------------------------------------------
 mkPrimOpIdUnique op         = mkUnique '9' op
 mkPreludeMiscIdUnique  i    = mkUnique '0' i
 
--- No numbers left anymore, so I pick something different for the character tag
-mkPArrDataConUnique a           = mkUnique ':' (2*a)
-
 -- The "tyvar uniques" print specially nicely: a, b, c, etc.
 -- See pprUnique for details
 
@@ -434,3 +437,6 @@ mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)
 mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)
 mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)
 mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)
+
+initExitJoinUnique :: Unique
+initExitJoinUnique = mkUnique 's' 0
diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index 87c4fe2240..2009b6c764 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -35,7 +35,7 @@
 module Var (
         -- * The main data type and synonyms
         Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId,
-        TyVar, TypeVar, KindVar, TKVar, TyCoVar,
+        TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar,
 
         -- * In and Out variants
         InVar,  InCoVar,  InId,  InTyVar,
@@ -61,9 +61,12 @@ module Var (
         mustHaveLocalBinding,
 
         -- * TyVar's
-        TyVarBndr(..), ArgFlag(..), TyVarBinder,
-        binderVar, binderVars, binderArgFlag, binderKind,
+        VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder,
+        binderVar, binderVars, binderArgFlag, binderType,
         isVisibleArgFlag, isInvisibleArgFlag, sameVis,
+        mkTyCoVarBinder, mkTyCoVarBinders,
+        mkTyVarBinder, mkTyVarBinders,
+        isTyVarBinder,
 
         -- ** Constructing TyVar's
         mkTyVar, mkTcTyVar,
@@ -81,6 +84,8 @@ module Var (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TyCoRep( Type, Kind, pprKind )
 import {-# SOURCE #-}   TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv )
 import {-# SOURCE #-}   IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails,
@@ -125,6 +130,9 @@ type TyVar   = Var     -- Type *or* kind variable (historical)
 -- | Type or Kind Variable
 type TKVar   = Var     -- Type *or* kind variable (historical)
 
+-- | Type variable that might be a metavariable
+type TcTyVar = Var
+
 -- | Type Variable
 type TypeVar = Var     -- Definitely a type variable
 
@@ -158,7 +166,7 @@ type TyCoVar = Id       -- Type, *or* coercion variable
 
 
 {- Many passes apply a substitution, and it's very handy to have type
-   synonyms to remind us whether or not the subsitution has been applied -}
+   synonyms to remind us whether or not the substitution has been applied -}
 
 type InVar      = Var
 type InTyVar    = TyVar
@@ -184,7 +192,7 @@ type OutId      = Id
 Note [Kind and type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Before kind polymorphism, TyVar were used to mean type variables. Now
-they are use to mean kind *or* type variables. KindVar is used when we
+they are used to mean kind *or* type variables. KindVar is used when we
 know for sure that it is a kind variable. In future, we might want to
 go over the whole compiler code to use:
    - TKVar   to mean kind or type variables
@@ -374,9 +382,10 @@ updateVarTypeM f id = do { ty' <- f (varType id)
 -- Is something required to appear in source Haskell ('Required'),
 -- permitted by request ('Specified') (visible type application), or
 -- prohibited entirely from appearing in source Haskell ('Inferred')?
--- See Note [TyBinders and ArgFlags] in TyCoRep
-data ArgFlag = Required | Specified | Inferred
-  deriving (Eq, Data)
+-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep
+data ArgFlag = Inferred | Specified | Required
+  deriving (Eq, Ord, Data)
+  -- (<) on ArgFlag meant "is less visible than"
 
 -- | Does this 'ArgFlag' classify an argument that is written in Haskell?
 isVisibleArgFlag :: ArgFlag -> Bool
@@ -398,36 +407,67 @@ sameVis _        _        = True
 
 {- *********************************************************************
 *                                                                      *
-*                   TyVarBndr, TyVarBinder
+*                   VarBndr, TyCoVarBinder
 *                                                                      *
 ********************************************************************* -}
 
--- Type Variable Binder
+-- Variable Binder
 --
--- TyVarBndr is polymorphic in both tyvar and visibility fields:
---   * tyvar can be TyVar or IfaceTv
---   * argf  can be ArgFlag or TyConBndrVis
-data TyVarBndr tyvar argf = TvBndr tyvar argf
+-- VarBndr is polymorphic in both var and visibility fields.
+-- Currently there are six different uses of 'VarBndr':
+--   * Var.TyVarBinder   = VarBndr TyVar ArgFlag
+--   * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag
+--   * TyCon.TyConBinder     = VarBndr TyVar TyConBndrVis
+--   * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis
+--   * IfaceType.IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag
+--   * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
+data VarBndr var argf = Bndr var argf
   deriving( Data )
 
--- | Type Variable Binder
+-- | Variable Binder
 --
--- A 'TyVarBinder' is the binder of a ForAllTy
+-- A 'TyCoVarBinder' is the binder of a ForAllTy
 -- It's convenient to define this synonym here rather its natural
 -- home in TyCoRep, because it's used in DataCon.hs-boot
-type TyVarBinder = TyVarBndr TyVar ArgFlag
+--
+-- A 'TyVarBinder' is a binder with only TyVar
+type TyCoVarBinder = VarBndr TyCoVar ArgFlag
+type TyVarBinder   = VarBndr TyVar ArgFlag
 
-binderVar :: TyVarBndr tv argf -> tv
-binderVar (TvBndr v _) = v
+binderVar :: VarBndr tv argf -> tv
+binderVar (Bndr v _) = v
 
-binderVars :: [TyVarBndr tv argf] -> [tv]
+binderVars :: [VarBndr tv argf] -> [tv]
 binderVars tvbs = map binderVar tvbs
 
-binderArgFlag :: TyVarBndr tv argf -> argf
-binderArgFlag (TvBndr _ argf) = argf
+binderArgFlag :: VarBndr tv argf -> argf
+binderArgFlag (Bndr _ argf) = argf
+
+binderType :: VarBndr TyCoVar argf -> Type
+binderType (Bndr tv _) = varType tv
+
+-- | Make a named binder
+mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder
+mkTyCoVarBinder vis var = Bndr var vis
+
+-- | Make a named binder
+-- 'var' should be a type variable
+mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder
+mkTyVarBinder vis var
+  = ASSERT( isTyVar var )
+    Bndr var vis
+
+-- | Make many named binders
+mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder]
+mkTyCoVarBinders vis = map (mkTyCoVarBinder vis)
+
+-- | Make many named binders
+-- Input vars should be type variables
+mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]
+mkTyVarBinders vis = map (mkTyVarBinder vis)
 
-binderKind :: TyVarBndr TyVar argf -> Kind
-binderKind (TvBndr tv _) = tyVarKind tv
+isTyVarBinder :: TyCoVarBinder -> Bool
+isTyVarBinder (Bndr v _) = isTyVar v
 
 {-
 ************************************************************************
@@ -485,20 +525,20 @@ setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
 setTcTyVarDetails tv details = tv { tc_tv_details = details }
 
 -------------------------------------
-instance Outputable tv => Outputable (TyVarBndr tv ArgFlag) where
-  ppr (TvBndr v Required)  = ppr v
-  ppr (TvBndr v Specified) = char '@' <> ppr v
-  ppr (TvBndr v Inferred)  = braces (ppr v)
+instance Outputable tv => Outputable (VarBndr tv ArgFlag) where
+  ppr (Bndr v Required)  = ppr v
+  ppr (Bndr v Specified) = char '@' <> ppr v
+  ppr (Bndr v Inferred)  = braces (ppr v)
 
 instance Outputable ArgFlag where
   ppr Required  = text "[req]"
   ppr Specified = text "[spec]"
   ppr Inferred  = text "[infrd]"
 
-instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where
-  put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis }
+instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where
+  put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis }
 
-  get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) }
+  get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) }
 
 
 instance Binary ArgFlag where
diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index e22c207858..3e4844772d 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -34,7 +34,7 @@ module VarEnv (
         extendDVarEnvList,
         lookupDVarEnv, elemDVarEnv,
         isEmptyDVarEnv, foldDVarEnv,
-        mapDVarEnv,
+        mapDVarEnv, filterDVarEnv,
         modifyDVarEnv,
         alterDVarEnv,
         plusDVarEnv, plusDVarEnv_C,
@@ -73,6 +73,8 @@ module VarEnv (
         emptyTidyEnv
     ) where
 
+import GhcPrelude
+
 import OccName
 import Var
 import VarSet
@@ -129,7 +131,7 @@ extendInScopeSet (InScope in_scope n) v
 
 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
 extendInScopeSetList (InScope in_scope n) vs
-   = InScope (foldl (\s v -> extendVarSet s v) in_scope vs)
+   = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs)
                     (n + length vs)
 
 extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet
@@ -555,6 +557,9 @@ foldDVarEnv = foldUDFM
 mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b
 mapDVarEnv = mapUDFM
 
+filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a
+filterDVarEnv = filterUDFM
+
 alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a
 alterDVarEnv = alterUDFM
 
diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index 710cb0db3a..ac3c545b2a 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -45,6 +45,8 @@ module VarSet (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Var      ( Var, TyVar, CoVar, TyCoVar, Id )
 import Unique
 import Name     ( Name )
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs
index a5cff38a98..e6ac15f4a8 100644
--- a/compiler/cmm/Bitmap.hs
+++ b/compiler/cmm/Bitmap.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
 
 --
 -- (c) The University of Glasgow 2003-2006
@@ -15,8 +15,7 @@ module Bitmap (
         seqBitmap,
   ) where
 
-#include "HsVersions.h"
-#include "../includes/MachDeps.h"
+import GhcPrelude
 
 import SMRep
 import DynFlags
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index 8f11ad194b..4f4e0e8c53 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -8,14 +8,15 @@ module BlockId
   , blockLbl, infoTblLbl
   ) where
 
+import GhcPrelude
+
 import CLabel
 import IdInfo
 import Name
 import Unique
 import UniqSupply
 
-import Hoopl.Label (Label, uniqueToLbl)
-import Hoopl.Unique (intToUnique)
+import Hoopl.Label (Label, mkHooplLabel)
 
 ----------------------------------------------------------------
 --- Block Ids, their environments, and their sets
@@ -32,13 +33,14 @@ compilation unit in which it appears.
 type BlockId = Label
 
 mkBlockId :: Unique -> BlockId
-mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
+mkBlockId unique = mkHooplLabel $ getKey unique
 
 newBlockId :: MonadUnique m => m BlockId
 newBlockId = mkBlockId <$> getUniqueM
 
 blockLbl :: BlockId -> CLabel
-blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
+blockLbl label = mkLocalBlockLabel (getUnique label)
 
 infoTblLbl :: BlockId -> CLabel
-infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
+infoTblLbl label
+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
diff --git a/compiler/cmm/BlockId.hs-boot b/compiler/cmm/BlockId.hs-boot
new file mode 100644
index 0000000000..3ad4141184
--- /dev/null
+++ b/compiler/cmm/BlockId.hs-boot
@@ -0,0 +1,8 @@
+module BlockId (BlockId, mkBlockId) where
+
+import Hoopl.Label (Label)
+import Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 62c8037e9c..12c3357e47 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -15,30 +15,22 @@ module CLabel (
 
         mkClosureLabel,
         mkSRTLabel,
-        mkTopSRTLabel,
         mkInfoTableLabel,
         mkEntryLabel,
-        mkSlowEntryLabel,
-        mkConEntryLabel,
         mkRednCountsLabel,
         mkConInfoTableLabel,
-        mkLargeSRTLabel,
         mkApEntryLabel,
         mkApInfoTableLabel,
         mkClosureTableLabel,
         mkBytesLabel,
 
+        mkLocalBlockLabel,
         mkLocalClosureLabel,
         mkLocalInfoTableLabel,
-        mkLocalEntryLabel,
-        mkLocalConEntryLabel,
-        mkLocalConInfoTableLabel,
         mkLocalClosureTableLabel,
 
-        mkReturnPtLabel,
-        mkReturnInfoLabel,
-        mkAltLabel,
-        mkDefaultLabel,
+        mkBlockInfoTableLabel,
+
         mkBitmapLabel,
         mkStringLitLabel,
 
@@ -53,18 +45,18 @@ module CLabel (
         mkBHUpdInfoLabel,
         mkIndStaticInfoLabel,
         mkMainCapabilityLabel,
-        mkMAP_FROZEN_infoLabel,
-        mkMAP_FROZEN0_infoLabel,
+        mkMAP_FROZEN_CLEAN_infoLabel,
+        mkMAP_FROZEN_DIRTY_infoLabel,
         mkMAP_DIRTY_infoLabel,
-        mkSMAP_FROZEN_infoLabel,
-        mkSMAP_FROZEN0_infoLabel,
+        mkSMAP_FROZEN_CLEAN_infoLabel,
+        mkSMAP_FROZEN_DIRTY_infoLabel,
         mkSMAP_DIRTY_infoLabel,
-        mkEMPTY_MVAR_infoLabel,
+        mkBadAlignmentLabel,
         mkArrWords_infoLabel,
+        mkSRTInfoLabel,
 
         mkTopTickyCtrLabel,
         mkCAFBlackHoleInfoTableLabel,
-        mkCAFBlackHoleEntryLabel,
         mkRtsPrimOpLabel,
         mkRtsSlowFastTickyCtrLabel,
 
@@ -102,21 +94,28 @@ module CLabel (
 
         mkHpcTicksLabel,
 
+        -- * Predicates
         hasCAF,
-        needsCDecl, maybeAsmTemp, externallyVisibleCLabel,
+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
         isMathFun,
         isCFunctionLabel, isGcPtrLabel, labelDynamic,
+        isLocalCLabel,
 
         -- * Conversions
-        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, toRednCountsLbl, hasHaskellName,
+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
 
-        pprCLabel
+        pprCLabel,
+        isInfoTableLabel,
+        isConInfoTableLabel
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import IdInfo
 import BasicTypes
+import {-# SOURCE #-} BlockId (BlockId, mkBlockId)
 import Packages
 import Module
 import Name
@@ -135,8 +134,8 @@ import PprCore ( {- instances -} )
 -- -----------------------------------------------------------------------------
 -- The CLabel type
 
-{-
-  | CLabel is an abstract type that supports the following operations:
+{- |
+  'CLabel' is an abstract type that supports the following operations:
 
   - Pretty printing
 
@@ -155,6 +154,25 @@ import PprCore ( {- instances -} )
     more than one declaration for any given label).
 
   - Converting an info table label into an entry label.
+
+  CLabel usage is a bit messy in GHC as they are used in a number of different
+  contexts:
+
+  - By the C-- AST to identify labels
+
+  - By the unregisterised C code generator ("PprC") for naming functions (hence
+    the name 'CLabel')
+
+  - By the native and LLVM code generators to identify labels
+
+  For extra fun, each of these uses a slightly different subset of constructors
+  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and
+  LLVM backends).
+
+  In general, we use 'IdLabel' to represent Haskell things early in the
+  pipeline. However, later optimization passes will often represent blocks they
+  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the
+  label.
 -}
 
 data CLabel
@@ -177,6 +195,14 @@ data CLabel
   | RtsLabel
         RtsLabelInfo
 
+  -- | A label associated with a block. These aren't visible outside of the
+  -- compilation unit in which they are defined. These are generally used to
+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,
+  -- where we don't have a 'Name' to associate the label to and therefore can't
+  -- use 'IdLabel'.
+  | LocalBlockLabel
+        {-# UNPACK #-} !Unique
+
   -- | A 'C' (or otherwise foreign) label.
   --
   | ForeignLabel
@@ -190,14 +216,13 @@ data CLabel
 
         FunctionOrData
 
-  -- | A family of labels related to a particular case expression.
-  | CaseLabel
-        {-# UNPACK #-} !Unique  -- Unique says which case expression
-        CaseLabelInfo
-
+  -- | Local temporary label used for native (or LLVM) code generation; must not
+  -- appear outside of these contexts. Use primarily for debug information
   | AsmTempLabel
         {-# UNPACK #-} !Unique
 
+  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.
+  -- Must not occur outside of the NCG or LLVM code generators.
   | AsmTempDerivedLabel
         CLabel
         FastString              -- suffix
@@ -229,10 +254,7 @@ data CLabel
   | HpcTicksLabel Module
 
   -- | Static reference table
-  | SRTLabel !Unique
-
-  -- | Label of an StgLargeSRT
-  | LargeSRTLabel
+  | SRTLabel
         {-# UNPACK #-} !Unique
 
   -- | A bitmap (function or case return)
@@ -256,14 +278,12 @@ instance Ord CLabel where
     compare b1 b2 `thenCmp`
     compare c1 c2
   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
   compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
     compare a1 a2 `thenCmp`
     compare b1 b2 `thenCmp`
     compare c1 c2 `thenCmp`
     compare d1 d2
-  compare (CaseLabel u1 a1) (CaseLabel u2 a2) =
-    nonDetCmpUnique u1 u2 `thenCmp`
-    compare a1 a2
   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
     compare a1 a2 `thenCmp`
@@ -284,8 +304,6 @@ instance Ord CLabel where
     compare a1 a2
   compare (SRTLabel u1) (SRTLabel u2) =
     nonDetCmpUnique u1 u2
-  compare (LargeSRTLabel u1) (LargeSRTLabel u2) =
-    nonDetCmpUnique u1 u2
   compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
     nonDetCmpUnique u1 u2
   compare IdLabel{} _ = LT
@@ -294,10 +312,10 @@ instance Ord CLabel where
   compare _ CmmLabel{} = GT
   compare RtsLabel{} _ = LT
   compare _ RtsLabel{} = GT
+  compare LocalBlockLabel{} _ = LT
+  compare _ LocalBlockLabel{} = GT
   compare ForeignLabel{} _ = LT
   compare _ ForeignLabel{} = GT
-  compare CaseLabel{} _ = LT
-  compare _ CaseLabel{} = GT
   compare AsmTempLabel{} _ = LT
   compare _ AsmTempLabel{} = GT
   compare AsmTempDerivedLabel{} _ = LT
@@ -318,8 +336,6 @@ instance Ord CLabel where
   compare _ HpcTicksLabel{} = GT
   compare SRTLabel{} _ = LT
   compare _ SRTLabel{} = GT
-  compare LargeSRTLabel{} _ = LT
-  compare _ LargeSRTLabel{} = GT
 
 -- | Record where a foreign label is stored.
 data ForeignLabelSource
@@ -350,7 +366,8 @@ data ForeignLabelSource
 pprDebugCLabel :: CLabel -> SDoc
 pprDebugCLabel lbl
  = case lbl of
-        IdLabel{}       -> ppr lbl <> (parens $ text "IdLabel")
+        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
+                                       <> whenPprDebug (text ":" <> text (show info)))
         CmmLabel pkg _name _info
          -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
 
@@ -367,9 +384,6 @@ pprDebugCLabel lbl
 
 data IdLabelInfo
   = Closure             -- ^ Label for closure
-  | SRT                 -- ^ Static reference table (TODO: could be removed
-                        -- with the old code generator, but might be needed
-                        -- when we implement the New SRT Plan)
   | InfoTable           -- ^ Info tables for closures; always read-only
   | Entry               -- ^ Entry point
   | Slow                -- ^ Slow entry point
@@ -386,16 +400,11 @@ data IdLabelInfo
 
   | Bytes               -- ^ Content of a string literal. See
                         -- Note [Bytes label].
+  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block
+                        -- instead of a closure entry-point.
+                        -- See Note [Proc-point local block entry-point].
 
-  deriving (Eq, Ord)
-
-
-data CaseLabelInfo
-  = CaseReturnPt
-  | CaseReturnInfo
-  | CaseAlt ConTag
-  | CaseDefault
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 
 data RtsLabelInfo
@@ -443,73 +452,88 @@ data DynamicLinkerLabelInfo
 
 -- Constructing IdLabels
 -- These are always local:
-mkSlowEntryLabel :: Name -> CafInfo -> CLabel
-mkSlowEntryLabel        name c         = IdLabel name  c Slow
 
-mkTopSRTLabel     :: Unique -> CLabel
-mkTopSRTLabel u = SRTLabel u
+mkSRTLabel     :: Unique -> CLabel
+mkSRTLabel u = SRTLabel u
 
-mkSRTLabel        :: Name -> CafInfo -> CLabel
 mkRednCountsLabel :: Name -> CLabel
-mkSRTLabel              name c  = IdLabel name  c SRT
 mkRednCountsLabel       name    =
   IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]
 
 -- These have local & (possibly) external variants:
 mkLocalClosureLabel      :: Name -> CafInfo -> CLabel
 mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel
-mkLocalEntryLabel        :: Name -> CafInfo -> CLabel
 mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
 mkLocalClosureLabel     name c  = IdLabel name  c Closure
 mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable
-mkLocalEntryLabel       name c  = IdLabel name  c LocalEntry
 mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
 
 mkClosureLabel              :: Name -> CafInfo -> CLabel
 mkInfoTableLabel            :: Name -> CafInfo -> CLabel
 mkEntryLabel                :: Name -> CafInfo -> CLabel
 mkClosureTableLabel         :: Name -> CafInfo -> CLabel
-mkLocalConInfoTableLabel    :: CafInfo -> Name -> CLabel
-mkLocalConEntryLabel        :: CafInfo -> Name -> CLabel
 mkConInfoTableLabel         :: Name -> CafInfo -> CLabel
 mkBytesLabel                :: Name -> CLabel
 mkClosureLabel name         c     = IdLabel name c Closure
 mkInfoTableLabel name       c     = IdLabel name c InfoTable
 mkEntryLabel name           c     = IdLabel name c Entry
 mkClosureTableLabel name    c     = IdLabel name c ClosureTable
-mkLocalConInfoTableLabel    c con = IdLabel con c ConInfoTable
-mkLocalConEntryLabel        c con = IdLabel con c ConEntry
 mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable
 mkBytesLabel name                 = IdLabel name NoCafRefs Bytes
 
-mkConEntryLabel       :: Name -> CafInfo -> CLabel
-mkConEntryLabel name        c     = IdLabel name c ConEntry
+mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
+                               -- See Note [Proc-point local block entry-point].
 
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
-    mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,
-    mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
-    mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
-    mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
-    mkSMAP_DIRTY_infoLabel :: CLabel
+    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
+    mkMAP_DIRTY_infoLabel,
+    mkArrWords_infoLabel,
+    mkTopTickyCtrLabel,
+    mkCAFBlackHoleInfoTableLabel,
+    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
 mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
-mkMAP_FROZEN_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
-mkMAP_FROZEN0_infoLabel         = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
 mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkEMPTY_MVAR_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_EMPTY_MVAR")        CmmInfo
 mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData
 mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
-mkCAFBlackHoleEntryLabel        = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmEntry
 mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo
-mkSMAP_FROZEN_infoLabel         = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
-mkSMAP_FROZEN0_infoLabel        = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
 mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry
+
+mkSRTInfoLabel :: Int -> CLabel
+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+ where
+   lbl =
+     case n of
+       1 -> fsLit "stg_SRT_1"
+       2 -> fsLit "stg_SRT_2"
+       3 -> fsLit "stg_SRT_3"
+       4 -> fsLit "stg_SRT_4"
+       5 -> fsLit "stg_SRT_5"
+       6 -> fsLit "stg_SRT_6"
+       7 -> fsLit "stg_SRT_7"
+       8 -> fsLit "stg_SRT_8"
+       9 -> fsLit "stg_SRT_9"
+       10 -> fsLit "stg_SRT_10"
+       11 -> fsLit "stg_SRT_11"
+       12 -> fsLit "stg_SRT_12"
+       13 -> fsLit "stg_SRT_13"
+       14 -> fsLit "stg_SRT_14"
+       15 -> fsLit "stg_SRT_15"
+       16 -> fsLit "stg_SRT_16"
+       _ -> panic "mkSRTInfoLabel"
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
@@ -524,6 +548,8 @@ mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
 mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
 mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
 
+mkLocalBlockLabel :: Unique -> CLabel
+mkLocalBlockLabel u = LocalBlockLabel u
 
 -- Constructing RtsLabels
 mkRtsPrimOpLabel :: PrimOp -> CLabel
@@ -592,13 +618,24 @@ isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
 isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
 isSomeRODataLabel (IdLabel _ _ InfoTable) = True
 isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
--- static reference tables defined in haskell (.hs)
-isSomeRODataLabel (IdLabel _ _ SRT) = True
-isSomeRODataLabel (SRTLabel _) = True
+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
 -- info table defined in cmm (.cmm)
 isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
 isSomeRODataLabel _lbl = False
 
+-- | Whether label is points to some kind of info table
+isInfoTableLabel :: CLabel -> Bool
+isInfoTableLabel (IdLabel _ _ InfoTable)      = True
+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True
+isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True
+isInfoTableLabel _                            = False
+
+-- | Whether label is points to constructor info table
+isConInfoTableLabel :: CLabel -> Bool
+isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isConInfoTableLabel _                            = False
+
 -- | Get the label size field from a ForeignLabel
 foreignLabelStdcallInfo :: CLabel -> Maybe Int
 foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
@@ -606,22 +643,9 @@ foreignLabelStdcallInfo _lbl = Nothing
 
 
 -- Constructing Large*Labels
-mkLargeSRTLabel :: Unique -> CLabel
 mkBitmapLabel   :: Unique -> CLabel
-mkLargeSRTLabel uniq            = LargeSRTLabel uniq
 mkBitmapLabel   uniq            = LargeBitmapLabel uniq
 
-
--- Constructin CaseLabels
-mkReturnPtLabel   :: Unique -> CLabel
-mkReturnInfoLabel :: Unique -> CLabel
-mkAltLabel        :: Unique -> ConTag -> CLabel
-mkDefaultLabel    :: Unique -> CLabel
-mkReturnPtLabel uniq            = CaseLabel uniq CaseReturnPt
-mkReturnInfoLabel uniq          = CaseLabel uniq CaseReturnInfo
-mkAltLabel      uniq tag        = CaseLabel uniq (CaseAlt tag)
-mkDefaultLabel  uniq            = CaseLabel uniq CaseDefault
-
 -- Constructing Cost Center Labels
 mkCCLabel  :: CostCentre      -> CLabel
 mkCCSLabel :: CostCentreStack -> CLabel
@@ -682,31 +706,29 @@ toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
 toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
 
 toSlowEntryLbl :: CLabel -> CLabel
+toSlowEntryLbl (IdLabel n _ BlockInfoTable)
+  = pprPanic "toSlowEntryLbl" (ppr n)
 toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow
 toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
 
 toEntryLbl :: CLabel -> CLabel
 toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry
 toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry
+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)
+                              -- See Note [Proc-point local block entry-point].
 toEntryLbl (IdLabel n c _)               = IdLabel n c Entry
-toEntryLbl (CaseLabel n CaseReturnInfo)  = CaseLabel n CaseReturnPt
 toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry
 toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet
 toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
 
 toInfoLbl :: CLabel -> CLabel
-toInfoLbl (IdLabel n c Entry)          = IdLabel n c InfoTable
 toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable
 toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable
 toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable
-toInfoLbl (CaseLabel n CaseReturnPt)   = CaseLabel n CaseReturnInfo
 toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo
 toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo
 toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
 
-toRednCountsLbl :: CLabel -> Maybe CLabel
-toRednCountsLbl = fmap mkRednCountsLabel . hasHaskellName
-
 hasHaskellName :: CLabel -> Maybe Name
 hasHaskellName (IdLabel n _ _) = Just n
 hasHaskellName _               = Nothing
@@ -747,10 +769,9 @@ needsCDecl :: CLabel -> Bool
   -- don't bother declaring Bitmap labels, we always make sure
   -- they are defined before use.
 needsCDecl (SRTLabel _)                 = True
-needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
-needsCDecl (CaseLabel _ _)              = True
+needsCDecl (LocalBlockLabel _)          = True
 
 needsCDecl (StringLitLabel _)           = False
 needsCDecl (AsmTempLabel _)             = False
@@ -773,11 +794,11 @@ needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
 needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
 needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
 
--- | If a label is a local temporary used for native code generation
---      then return just its unique, otherwise nothing.
-maybeAsmTemp :: CLabel -> Maybe Unique
-maybeAsmTemp (AsmTempLabel uq)          = Just uq
-maybeAsmTemp _                          = Nothing
+-- | If a label is a local block label then return just its 'BlockId', otherwise
+-- 'Nothing'.
+maybeLocalBlockLabel :: CLabel -> Maybe BlockId
+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq
+maybeLocalBlockLabel _                     = Nothing
 
 
 -- | Check whether a label corresponds to a C function that has
@@ -880,11 +901,11 @@ math_funs = mkUniqSet [
 --      externally visible if it has to be declared as exported
 --      in the .o file's symbol table; that is, made non-static.
 externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
-externallyVisibleCLabel (CaseLabel _ _)         = False
 externallyVisibleCLabel (StringLitLabel _)      = False
 externallyVisibleCLabel (AsmTempLabel _)        = False
 externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
 externallyVisibleCLabel (RtsLabel _)            = True
+externallyVisibleCLabel (LocalBlockLabel _)     = False
 externallyVisibleCLabel (CmmLabel _ _ _)        = True
 externallyVisibleCLabel (ForeignLabel{})        = True
 externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info
@@ -894,14 +915,13 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)       = True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
 externallyVisibleCLabel (SRTLabel _)            = False
-externallyVisibleCLabel (LargeSRTLabel _)       = False
 externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
 externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
 
 externallyVisibleIdLabel :: IdLabelInfo -> Bool
-externallyVisibleIdLabel SRT             = False
 externallyVisibleIdLabel LocalInfoTable  = False
 externallyVisibleIdLabel LocalEntry      = False
+externallyVisibleIdLabel BlockInfoTable  = False
 externallyVisibleIdLabel _               = True
 
 -- -----------------------------------------------------------------------------
@@ -928,6 +948,7 @@ isGcPtrLabel lbl = case labelType lbl of
 -- | Work out the general type of data at the address of this label
 --    whether it be code, data, or static GC object.
 labelType :: CLabel -> CLabelType
+labelType (IdLabel _ _ info)                    = idInfoLabelType info
 labelType (CmmLabel _ _ CmmData)                = DataLabel
 labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
 labelType (CmmLabel _ _ CmmCode)                = CodeLabel
@@ -939,20 +960,28 @@ labelType (CmmLabel _ _ CmmRet)                 = CodeLabel
 labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
 labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
 labelType (RtsLabel (RtsApFast _))              = CodeLabel
-labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
-labelType (CaseLabel _ _)                       = CodeLabel
+labelType (RtsLabel _)                          = DataLabel
+labelType (LocalBlockLabel _)                   = CodeLabel
 labelType (SRTLabel _)                          = DataLabel
-labelType (LargeSRTLabel _)                     = DataLabel
-labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
-labelType (IdLabel _ _ info)                    = idInfoLabelType info
-labelType _                                     = DataLabel
+labelType (ForeignLabel _ _ _ IsData)           = DataLabel
+labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"
+labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"
+labelType (StringLitLabel _)                    = DataLabel
+labelType (CC_Label _)                          = DataLabel
+labelType (CCS_Label _)                         = DataLabel
+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?
+labelType PicBaseLabel                          = DataLabel
+labelType (DeadStripPreventer _)                = DataLabel
+labelType (HpcTicksLabel _)                     = DataLabel
+labelType (LargeBitmapLabel _)                  = DataLabel
 
 idInfoLabelType :: IdLabelInfo -> CLabelType
 idInfoLabelType info =
   case info of
     InfoTable     -> DataLabel
     LocalInfoTable -> DataLabel
+    BlockInfoTable -> DataLabel
     Closure       -> GcPtrLabel
     ConInfoTable  -> DataLabel
     ClosureTable  -> DataLabel
@@ -962,28 +991,48 @@ idInfoLabelType info =
 
 
 -- -----------------------------------------------------------------------------
--- Does a CLabel need dynamic linkage?
 
+-- | Is a 'CLabel' defined in the current module being compiled?
+--
+-- Sometimes we can optimise references within a compilation unit in ways that
+-- we couldn't for inter-module references. This provides a conservative
+-- estimate of whether a 'CLabel' lives in the current module.
+isLocalCLabel :: Module -> CLabel -> Bool
+isLocalCLabel this_mod lbl =
+  case lbl of
+    IdLabel name _ _
+      | isInternalName name -> True
+      | otherwise           -> nameModule name == this_mod
+    LocalBlockLabel _       -> True
+    _                       -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | Does a 'CLabel' need dynamic linkage?
+--
 -- When referring to data in code, we need to know whether
 -- that data resides in a DLL or not. [Win32 only.]
 -- @labelDynamic@ returns @True@ if the label is located
 -- in a DLL, be it a data reference or not.
-
 labelDynamic :: DynFlags -> Module -> CLabel -> Bool
 labelDynamic dflags this_mod lbl =
   case lbl of
    -- is the RTS in a DLL or not?
-   RtsLabel _           -> (WayDyn `elem` ways dflags) && (this_pkg /= rtsUnitId)
+   RtsLabel _ ->
+     (gopt Opt_ExternalDynamicRefs dflags) && (this_pkg /= rtsUnitId)
 
-   IdLabel n _ _        -> isDllName dflags this_mod n
+   IdLabel n _ _ ->
+     isDllName dflags this_mod n
 
    -- When compiling in the "dyn" way, each package is to be linked into
    -- its own shared library.
    CmmLabel pkg _ _
     | os == OSMinGW32 ->
-       (WayDyn `elem` ways dflags) && (this_pkg /= pkg)
+       (gopt Opt_ExternalDynamicRefs dflags) && (this_pkg /= pkg)
     | otherwise ->
-       True
+       gopt Opt_ExternalDynamicRefs dflags
+
+   LocalBlockLabel _    -> False
 
    ForeignLabel _ _ source _  ->
        if os == OSMinGW32
@@ -999,14 +1048,15 @@ labelDynamic dflags this_mod lbl =
             -- When compiling in the "dyn" way, each package is to be
             -- linked into its own DLL.
             ForeignLabelInPackage pkgId ->
-                (WayDyn `elem` ways dflags) && (this_pkg /= pkgId)
+                (gopt Opt_ExternalDynamicRefs dflags) && (this_pkg /= pkgId)
 
        else -- On Mac OS X and on ELF platforms, false positives are OK,
             -- so we claim that all foreign imports come from dynamic
             -- libraries
             True
 
-   HpcTicksLabel m        -> (WayDyn `elem` ways dflags) && this_mod /= m
+   HpcTicksLabel m ->
+     (gopt Opt_ExternalDynamicRefs dflags) && this_mod /= m
 
    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                 -> False
@@ -1028,7 +1078,6 @@ internal names. <type> is one of the following:
 
          info                   Info table
          srt                    Static reference table
-         srtd                   Static reference table descriptor
          entry                  Entry code (function, closure)
          slow                   Slow entry code (if any)
          ret                    Direct return address
@@ -1082,6 +1131,18 @@ Note [Bytes label]
 ~~~~~~~~~~~~~~~~~~
 For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
 points to a static data block containing the content of the literal.
+
+Note [Proc-point local block entry-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A label for a proc-point local block entry-point has no "_entry" suffix. With
+`infoTblLbl` we derive an info table label from a proc-point block ID. If
+we convert such an info table label into an entry label we must produce
+the label without an "_entry" suffix. So an info table label records
+the fact that it was derived from a block ID in `IdLabelInfo` as
+`BlockInfoTable`.
+
+The info table label and the local block label are both local labels
+and are not externally visible.
 -}
 
 instance Outputable CLabel where
@@ -1089,19 +1150,19 @@ instance Outputable CLabel where
 
 pprCLabel :: Platform -> CLabel -> SDoc
 
+pprCLabel _ (LocalBlockLabel u)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
 pprCLabel platform (AsmTempLabel u)
- | cGhcWithNativeCodeGen == "YES"
-  =  getPprStyle $ \ sty ->
-     if asmStyle sty then
-        ptext (asmTempLabelPrefix platform) <> pprUniqueAlways u
-     else
-        char '_' <> pprUniqueAlways u
+ | not (platformUnregisterised platform)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
 
 pprCLabel platform (AsmTempDerivedLabel l suf)
  | cGhcWithNativeCodeGen == "YES"
    = ptext (asmTempLabelPrefix platform)
-     <> case l of AsmTempLabel u -> pprUniqueAlways u
-                  _other         -> pprCLabel platform l
+     <> case l of AsmTempLabel u    -> pprUniqueAlways u
+                  LocalBlockLabel u -> pprUniqueAlways u
+                  _other            -> pprCLabel platform l
      <> ftext suf
 
 pprCLabel platform (DynamicLinkerLabel info lbl)
@@ -1114,7 +1175,15 @@ pprCLabel _ PicBaseLabel
 
 pprCLabel platform (DeadStripPreventer lbl)
  | cGhcWithNativeCodeGen == "YES"
-   = pprCLabel platform lbl <> text "_dsp"
+   =
+   {-
+      `lbl` can be temp one but we need to ensure that dsp label will stay
+      in the final binary so we prepend non-temp prefix ("dsp_") and
+      optional `_` (underscore) because this is how you mark non-temp symbols
+      on some platforms (Darwin)
+   -}
+   maybe_underscore $ text "dsp_"
+   <> pprCLabel platform lbl <> text "_dsp"
 
 pprCLabel _ (StringLitLabel u)
  | cGhcWithNativeCodeGen == "YES"
@@ -1144,29 +1213,24 @@ pprCLbl :: CLabel -> SDoc
 pprCLbl (StringLitLabel u)
   = pprUniqueAlways u <> text "_str"
 
-pprCLbl (CaseLabel u CaseReturnPt)
-  = hcat [pprUniqueAlways u, text "_ret"]
-pprCLbl (CaseLabel u CaseReturnInfo)
-  = hcat [pprUniqueAlways u, text "_info"]
-pprCLbl (CaseLabel u (CaseAlt tag))
-  = hcat [pprUniqueAlways u, pp_cSEP, int tag, text "_alt"]
-pprCLbl (CaseLabel u CaseDefault)
-  = hcat [pprUniqueAlways u, text "_dflt"]
-
 pprCLbl (SRTLabel u)
-  = pprUniqueAlways u <> pp_cSEP <> text "srt"
+  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
 
-pprCLbl (LargeSRTLabel u)  = pprUniqueAlways u <> pp_cSEP <> text "srtd"
-pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+pprCLbl (LargeBitmapLabel u)  =
+  tempLabelPrefixOrUnderscore
+  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
 -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
 -- until that gets resolved we'll just force them to start
--- with a letter so the label will be legal assmbly code.
+-- with a letter so the label will be legal assembly code.
 
 
 pprCLbl (CmmLabel _ str CmmCode)        = ftext str
 pprCLbl (CmmLabel _ str CmmData)        = ftext str
 pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
 
+pprCLbl (LocalBlockLabel u)             =
+    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
+
 pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"
 
 pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
@@ -1229,7 +1293,8 @@ pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
 pprCLbl (ForeignLabel str _ _ _)
   = ftext str
 
-pprCLbl (IdLabel name _cafs flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (IdLabel name _cafs flavor) =
+  internalNamePrefix name <> ppr name <> ppIdFlavor flavor
 
 pprCLbl (CC_Label cc)           = ppr cc
 pprCLbl (CCS_Label ccs)         = ppr ccs
@@ -1247,7 +1312,6 @@ ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <>
                (case x of
                        Closure          -> text "closure"
-                       SRT              -> text "srt"
                        InfoTable        -> text "info"
                        LocalInfoTable   -> text "info"
                        Entry            -> text "entry"
@@ -1258,6 +1322,7 @@ ppIdFlavor x = pp_cSEP <>
                        ConInfoTable     -> text "con_info"
                        ClosureTable     -> text "closure_tbl"
                        Bytes            -> text "bytes"
+                       BlockInfoTable   -> text "info"
                       )
 
 
@@ -1272,6 +1337,24 @@ instance Outputable ForeignLabelSource where
         ForeignLabelInThisPackage       -> parens $ text "this package"
         ForeignLabelInExternalPackage   -> parens $ text "external package"
 
+internalNamePrefix :: Name -> SDoc
+internalNamePrefix name = getPprStyle $ \ sty ->
+  if codeStyle sty && isRandomGenerated then
+    sdocWithPlatform $ \platform ->
+      ptext (asmTempLabelPrefix platform)
+  else
+    empty
+  where
+    isRandomGenerated = not $ isExternalName name
+
+tempLabelPrefixOrUnderscore :: SDoc
+tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
+  getPprStyle $ \ sty ->
+   if asmStyle sty then
+      ptext (asmTempLabelPrefix platform)
+   else
+      char '_'
+
 -- -----------------------------------------------------------------------------
 -- Machine-dependent knowledge about labels.
 
@@ -1285,53 +1368,62 @@ asmTempLabelPrefix platform = case platformOS platform of
     _        -> sLit ".L"
 
 pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
-pprDynamicLinkerAsmLabel platform dllInfo lbl
- = if platformOS platform == OSDarwin
-   then if platformArch platform == ArchX86_64
-        then case dllInfo of
-             CodeStub        -> char 'L' <> ppr lbl <> text "$stub"
-             SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
-             GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"
-             GotSymbolOffset -> ppr lbl
-        else case dllInfo of
-             CodeStub  -> char 'L' <> ppr lbl <> text "$stub"
-             SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
-             _         -> panic "pprDynamicLinkerAsmLabel"
-
-   else if platformOS platform == OSAIX
-        then case dllInfo of
-             SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
-             _         -> panic "pprDynamicLinkerAsmLabel"
-
-   else if osElfTarget (platformOS platform)
-        then if platformArch platform == ArchPPC
-             then case dllInfo of
-                       CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]
-                                    ppr lbl <> text "+32768@plt"
-                       SymbolPtr -> text ".LC_" <> ppr lbl
-                       _         -> panic "pprDynamicLinkerAsmLabel"
-             else if platformArch platform == ArchX86_64
-                  then case dllInfo of
-                       CodeStub        -> ppr lbl <> text "@plt"
-                       GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"
-                       GotSymbolOffset -> ppr lbl
-                       SymbolPtr       -> text ".LC_" <> ppr lbl
-             else if platformArch platform == ArchPPC_64 ELF_V1
-                  || platformArch platform == ArchPPC_64 ELF_V2
-                  then case dllInfo of
-                       GotSymbolPtr    -> text ".LC_"  <> ppr lbl
-                                               <> text "@toc"
-                       GotSymbolOffset -> ppr lbl
-                       SymbolPtr       -> text ".LC_" <> ppr lbl
-                       _               -> panic "pprDynamicLinkerAsmLabel"
-        else case dllInfo of
-             CodeStub        -> ppr lbl <> text "@plt"
-             SymbolPtr       -> text ".LC_" <> ppr lbl
-             GotSymbolPtr    -> ppr lbl <> text "@got"
-             GotSymbolOffset -> ppr lbl <> text "@gotoff"
-   else if platformOS platform == OSMinGW32
-        then case dllInfo of
-             SymbolPtr -> text "__imp_" <> ppr lbl
-             _         -> panic "pprDynamicLinkerAsmLabel"
-   else panic "pprDynamicLinkerAsmLabel"
-
+pprDynamicLinkerAsmLabel platform dllInfo lbl =
+    case platformOS platform of
+      OSDarwin
+        | platformArch platform == ArchX86_64 ->
+          case dllInfo of
+            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"
+            GotSymbolOffset -> ppr lbl
+        | otherwise ->
+          case dllInfo of
+            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      OSAIX ->
+          case dllInfo of
+            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ | osElfTarget (platformOS platform) -> elfLabel
+
+      OSMinGW32 ->
+          case dllInfo of
+            SymbolPtr -> text "__imp_" <> ppr lbl
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ -> panic "pprDynamicLinkerAsmLabel"
+  where
+    elfLabel
+      | platformArch platform == ArchPPC
+      = case dllInfo of
+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]
+                       ppr lbl <> text "+32768@plt"
+          SymbolPtr -> text ".LC_" <> ppr lbl
+          _         -> panic "pprDynamicLinkerAsmLabel"
+
+      | platformArch platform == ArchX86_64
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+
+      | platformArch platform == ArchPPC_64 ELF_V1
+        || platformArch platform == ArchPPC_64 ELF_V2
+      = case dllInfo of
+          GotSymbolPtr    -> text ".LC_"  <> ppr lbl
+                                  <> text "@toc"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          _               -> panic "pprDynamicLinkerAsmLabel"
+
+      | otherwise
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          GotSymbolPtr    -> ppr lbl <> text "@got"
+          GotSymbolOffset -> ppr lbl <> text "@gotoff"
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index dbd54236f5..eb34618e38 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -1,5 +1,5 @@
 -- Cmm representations using Hoopl's Graph CmmNode e x.
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE GADTs #-}
 
 module Cmm (
      -- * Cmm top-level datatypes
@@ -18,7 +18,6 @@ module Cmm (
      -- * Info Tables
      CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
      ClosureTypeInfo(..),
-     C_SRT(..), needsSRT,
      ProfilingInfo(..), ConstrDescription,
 
      -- * Statements, expressions and types
@@ -26,6 +25,10 @@ module Cmm (
      module CmmExpr,
   ) where
 
+import GhcPrelude
+
+import Id
+import CostCentre
 import CLabel
 import BlockId
 import CmmNode
@@ -39,8 +42,6 @@ import Outputable
 
 import Data.Word        ( Word8 )
 
-#include "HsVersions.h"
-
 -----------------------------------------------------------------------------
 --  Cmm, GenCmm
 -----------------------------------------------------------------------------
@@ -138,24 +139,28 @@ data CmmInfoTable
       cit_lbl  :: CLabel, -- Info table label
       cit_rep  :: SMRep,
       cit_prof :: ProfilingInfo,
-      cit_srt  :: C_SRT
+      cit_srt  :: Maybe CLabel,   -- empty, or a closure address
+      cit_clo  :: Maybe (Id, CostCentreStack)
+        -- Just (id,ccs) <=> build a static closure later
+        -- Nothing <=> don't build a static closure
+        --
+        -- Static closures for FUNs and THUNKs are *not* generated by
+        -- the code generator, because we might want to add SRT
+        -- entries to them later (for FUNs at least; THUNKs are
+        -- treated the same for consistency). See Note [SRTs] in
+        -- CmmBuildInfoTables, in particular the [FUN] optimisation.
+        --
+        -- This is strictly speaking not a part of the info table that
+        -- will be finally generated, but it's the only convenient
+        -- place to convey this information from the code generator to
+        -- where we build the static closures in
+        -- CmmBuildInfoTables.doSRTs.
     }
 
 data ProfilingInfo
   = NoProfilingInfo
   | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
 
--- C_SRT is what StgSyn.SRT gets translated to...
--- we add a label for the table, and expect only the 'offset/length' form
-
-data C_SRT = NoC_SRT
-           | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
-           deriving (Eq)
-
-needsSRT :: C_SRT -> Bool
-needsSRT NoC_SRT       = False
-needsSRT (C_SRT _ _ _) = True
-
 -----------------------------------------------------------------------------
 --              Static Data
 -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 5dd8ee4ef2..a8f89a1a9c 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,49 +1,140 @@
-{-# LANGUAGE BangPatterns, CPP, GADTs #-}
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
 
 module CmmBuildInfoTables
-    ( CAFSet, CAFEnv, cafAnal
-    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
-where
+  ( CAFSet, CAFEnv, cafAnal
+  , doSRTs, ModuleSRTInfo, emptySRT
+  ) where
 
-#include "HsVersions.h"
+import GhcPrelude hiding (succ)
 
+import Id
+import BlockId
 import Hoopl.Block
 import Hoopl.Graph
 import Hoopl.Label
 import Hoopl.Collections
 import Hoopl.Dataflow
+import Module
+import Platform
 import Digraph
-import Bitmap
 import CLabel
 import PprCmmDecl ()
 import Cmm
 import CmmUtils
-import CmmInfo
-import Data.List
 import DynFlags
 import Maybes
 import Outputable
 import SMRep
 import UniqSupply
-import Util
+import CostCentre
+import StgCmmHeap
 
 import PprCmm()
+import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Control.Monad
+import Data.Tuple
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+
+
+{- Note [SRTs]
+
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+|      |     +-----+---+---+---+
+|   -------->|SRT_2| | | | | 0 |
+|------|     +-----+-|-+-|-+---+
+|      |             |   |
+| code |             |   |
+|      |             v   v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor.  There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | |   | | | 0 |
++-----+-|-+- -+-|-+---+
+        |       |
+        v       v
+              +----+---+---+---+
+              |SRT2| | | | | 0 |
+              +----+-|-+-|-+---+
+                     |   |
+                     |   |
+                     v   v
 
-import qualified Prelude as P
-import Prelude hiding (succ)
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 
-foldSet :: (a -> b -> b) -> b -> Set a -> b
-foldSet = Set.foldr
+The following things have SRTs:
 
------------------------------------------------------------------------
--- SRTs
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
 
-{- EXAMPLE
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable       +------+
+  info->f.srt_offset  |  ------------> offset to SRT object
+StgStdInfoTable       +------+
+  info->layout.ptrs   | ...  |
+  info->layout.nptrs  | ...  |
+  info->srt           |  1   |
+  info->type          | ...  |
+                      |------|
+
+On x86_64, we optimise the info table representation further.  The
+offset to the SRT can be stored in 32 bits (all code lives within a
+2GB region in x86_64's small memory model), so we can save a word in
+the info table by storing the srt_offset in the srt field, which is
+half a word.
+
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt is an offset from the info pointer to the SRT object
+
+StgStdInfoTable       +------+
+  info->layout.ptrs   |      |
+  info->layout.nptrs  |      |
+  info->srt           |  ------------> offset to SRT object
+                      |------|
+
+
+EXAMPLE
+^^^^^^^
 
 f = \x. ... g ...
   where
@@ -65,29 +156,254 @@ CmmDecls. e.g. for f_entry, we might end up with
 where f1_ret is a return point, and f2_proc is a proc-point.  We have
 a CAFSet for each of these CmmDecls, let's suppose they are
 
-   [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
-   [ g_entry{h_closure, c1_closure} ]
+   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+   [ g_entry{h_info, c1_closure} ]
    [ h_entry{c2_closure} ]
 
-Now, note that we cannot use g_closure and h_closure in an SRT,
-because there are no static closures corresponding to these functions.
-So we have to flatten out the structure, replacing g_closure and
-h_closure with their contents:
+Next, we make an SRT for each of these functions:
 
-   [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
-   [ g_entry{c2_closure, c1_closure} ]
-   [ h_entry{c2_closure} ]
+  f_srt : [g_info]
+  g_srt : [h_info, c1_closure]
+  h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+  f_srt : [g_srt]
+  g_srt : [h_srt, c1_closure]
+  h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element.  So, since h_srt == c2_closure, we have
+
+  f_srt : [g_srt]
+  g_srt : [c2_closure, c1_closure]
+  h_srt : [c2_closure]
+
+and the only SRT closure we generate is
 
-This is what flattenCAFSets is doing.
+  g_srt = SRT_2 [c2_closure, c1_closure]
 
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations.  Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Inline] we never create an SRT with a single entry, instead we
+   point to the single entry directly from the info table.
+
+   i.e. instead of
+
+    +------+
+    | info |
+    |      |     +-----+---+---+
+    |   -------->|SRT_1| | | 0 |
+    |------|     +-----+-|-+---+
+    |      |             |
+    | code |             |
+    |      |             v
+                         C
+
+   we can point directly to the closure:
+
+    +------+
+    | info |
+    |      |
+    |   -------->C
+    |------|
+    |      |
+    | code |
+    |      |
+
+
+   Furthermore, the SRT for any code that refers to this info table
+   can point directly to C.
+
+   The exception to this is when we're doing dynamic linking. In that
+   case, if the closure is not locally defined then we can't point to
+   it directly from the info table, because this is the text section
+   which cannot contain runtime relocations. In this case we skip this
+   optimisation and generate the singleton SRT, becase SRTs are in the
+   data section and *can* have relocatable references.
+
+2. [FUN] A static function closure can also be an SRT, we simply put
+   the SRT entries as fields in the static closure.  This makes a lot
+   of sense: the static references are just like the free variables of
+   the FUN closure.
+
+   i.e. instead of
+
+   f_closure:
+   +-----+---+
+   |  |  | 0 |
+   +- |--+---+
+      |            +------+
+      |            | info |     f_srt:
+      |            |      |     +-----+---+---+---+
+      |            |   -------->|SRT_2| | | | + 0 |
+      `----------->|------|     +-----+-|-+-|-+---+
+                   |      |             |   |
+                   | code |             |   |
+                   |      |             v   v
+
+
+   We can generate:
+
+   f_closure:
+   +-----+---+---+---+
+   |  |  | | | | | 0 |
+   +- |--+-|-+-|-+---+
+      |    |   |   +------+
+      |    v   v   | info |
+      |            |      |
+      |            |   0  |
+      `----------->|------|
+                   |      |
+                   | code |
+                   |      |
+
+
+   (note: we can't do this for THUNKs, because the thunk gets
+   overwritten when it is entered, so we wouldn't be able to share
+   this SRT with other info tables that want to refer to it (see
+   [Common] below). FUNs are immutable so don't have this problem.)
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+   refers to C (perhaps transitively), then we can omit the reference
+   to C from A.
+
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Inline] C = A.
 -}
 
------------------------------------------------------------------------
--- Finding the CAFs used by a procedure
+-- ---------------------------------------------------------------------
+{- Note [Invalid optimisation: shortcutting]
+
+You might think that if we have something like
+
+A's SRT = {B}
+B's SRT = {X}
+
+that we could replace the reference to B in A's SRT with X.
+
+A's SRT = {X}
+B's SRT = {X}
 
-type CAFSet = Set CLabel
+and thereby perhaps save a little work at runtime, because we don't
+have to visit B.
+
+But this is NOT valid.
+
+Consider these cases:
+
+0. B can't be a constructor, because constructors don't have SRTs
+
+1. B is a CAF. This is the easy one. Obviously we want A's SRT to
+   point to B, so that it keeps B alive.
+
+2. B is a function.  This is the tricky one. The reason we can't
+shortcut in this case is that we aren't allowed to resurrect static
+objects.
+
+== How does this cause a problem? ==
+
+The particular case that cropped up when we tried this was #15544.
+- A is a thunk
+- B is a static function
+- X is a CAF
+- suppose we GC when A is alive, and B is not otherwise reachable.
+- B is "collected", meaning that it doesn't make it onto the static
+  objects list during this GC, but nothing bad happens yet.
+- Next, suppose we enter A, and then call B. (remember that A refers to B)
+  At the entry point to B, we GC. This puts B on the stack, as part of the
+  RET_FUN stack frame that gets pushed when we GC at a function entry point.
+- This GC will now reach B
+- But because B was previous "collected", it breaks the assumption
+  that static objects are never resurrected. See Note [STATIC_LINK
+  fields] in rts/sm/Storage.h for why this is bad.
+- In practice, the GC thinks that B has already been visited, and so
+  doesn't visit X, and catastrophe ensues.
+
+== Isn't this caused by the RET_FUN business? ==
+
+Maybe, but could you prove that RET_FUN is the only way that
+resurrection can occur?
+
+So, no shortcutting.
+-}
+
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+--   - _closure labels for static functions or CAFs
+--   - _info labels for dynamic functions, thunks, or continuations
+--   - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl.  Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+  deriving (Eq,Ord,Outputable)
+
+type CAFSet = Set CAFLabel
 type CAFEnv = LabelMap CAFSet
 
+mkCAFLabel :: CLabel -> CAFLabel
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+
+-- This is a label that we can put in an SRT.  It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+  deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+-- |
+-- For each code block:
+--   - collect the references reachable from this code block to FUN,
+--     THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+  :: LabelSet   -- The blocks representing continuations, ie. those
+                -- that will get RET info tables.  These labels will
+                -- get their own SRTs, so we don't aggregate CAFs from
+                -- references to these labels, we just use the label.
+  -> CLabel     -- The top label of the proc
+  -> CmmGraph
+  -> CAFEnv
+cafAnal contLbls topLbl cmmGraph =
+  analyzeCmmBwd cafLattice
+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
 cafLattice :: DataflowLattice CAFSet
 cafLattice = DataflowLattice Set.empty add
   where
@@ -95,290 +411,486 @@ cafLattice = DataflowLattice Set.empty add
         let !new' = old `Set.union` new
         in changedIf (Set.size new' > Set.size old) new'
 
-cafTransfers :: TransferFun CAFSet
-cafTransfers (BlockCC eNode middle xNode) fBase =
-    let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
+
+cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers contLbls entry topLbl
+  (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! live'
         !result = foldNodesBwdOO cafsInNode middle joined
+
+        facts = mapMaybe successorFact (successors xNode)
+        live' = joinFacts cafLattice facts
+
+        successorFact s
+          -- If this is a loop back to the entry, we can refer to the
+          -- entry label.
+          | s == entry = Just (add topLbl Set.empty)
+          -- If this is a continuation, we want to refer to the
+          -- SRT for the continuation's info table
+          | s `setMember` contLbls
+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+          -- Otherwise, takes the CAF references from the destination
+          | otherwise
+          = lookupFact s fBase
+
+        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+        cafsInNode node set = foldExpDeep addCaf node set
+
+        addCaf expr !set =
+          case expr of
+              CmmLit (CmmLabel c) -> add c set
+              CmmLit (CmmLabelOff c _) -> add c set
+              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set
+              _ -> set
+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s
+                | otherwise = s
+
     in mapSingleton (entryLabel eNode) result
 
-cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
-cafsInNode node set = foldExpDeep addCaf node set
-  where
-    addCaf expr !set =
-        case expr of
-            CmmLit (CmmLabel c) -> add c set
-            CmmLit (CmmLabelOff c _) -> add c set
-            CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
-            _ -> set
-    add l s | hasCAF l  = Set.insert (toClosureLbl l) s
-            | otherwise = s
-
--- | An analysis to find live CAFs.
-cafAnal :: CmmGraph -> CAFEnv
-cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
-
------------------------------------------------------------------------
--- Building the SRTs
-
--- Description of the SRT for a given module.
--- Note that this SRT may grow as we greedily add new CAFs to it.
-data TopSRT = TopSRT { lbl      :: CLabel
-                     , next_elt :: Int -- the next entry in the table
-                     , rev_elts :: [CLabel]
-                     , elt_map  :: Map CLabel Int }
-                        -- map: CLabel -> its last entry in the table
-instance Outputable TopSRT where
-  ppr (TopSRT lbl next elts eltmap) =
-    text "TopSRT:" <+> ppr lbl
-                   <+> ppr next
-                   <+> ppr elts
-                   <+> ppr eltmap
-
-emptySRT :: MonadUnique m => m TopSRT
-emptySRT =
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
-     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
-
-isEmptySRT :: TopSRT -> Bool
-isEmptySRT srt = null (rev_elts srt)
-
-cafMember :: TopSRT -> CLabel -> Bool
-cafMember srt lbl = Map.member lbl (elt_map srt)
-
-cafOffset :: TopSRT -> CLabel -> Maybe Int
-cafOffset srt lbl = Map.lookup lbl (elt_map srt)
-
-addCAF :: CLabel -> TopSRT -> TopSRT
-addCAF caf srt =
-  srt { next_elt = last + 1
-      , rev_elts = caf : rev_elts srt
-      , elt_map  = Map.insert caf last (elt_map srt) }
-    where last  = next_elt srt
-
-srtToData :: TopSRT -> CmmGroup
-srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
-    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-          sec = Section RelocatableReadOnlyData (lbl srt)
-
--- Once we have found the CAFs, we need to do two things:
--- 1. Build a table of all the CAFs used in the procedure.
--- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
---
--- When building the local view of the SRT, we first make sure that all the CAFs are
--- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
--- we make sure they're all close enough to the bottom of the table that the
--- bitmap will be able to cover all of them.
-buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
-buildSRT dflags topSRT cafs =
-  do let
-         -- For each label referring to a function f without a static closure,
-         -- replace it with the CAFs that are reachable from f.
-         sub_srt topSRT localCafs =
-           let cafs = Set.elems localCafs
-               mkSRT topSRT =
-                 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
-                    return (topSRT, localSRTs)
-           in if cafs `lengthExceeds` maxBmpSize dflags then
-                mkSRT (foldl add_if_missing topSRT cafs)
-              else -- make sure all the cafs are near the bottom of the srt
-                mkSRT (add_if_too_far topSRT cafs)
-         add_if_missing srt caf =
-           if cafMember srt caf then srt else addCAF caf srt
-         -- If a CAF is more than maxBmpSize entries from the young end of the
-         -- SRT, then we add it to the SRT again.
-         -- (Note: Not in the SRT => infinitely far.)
-         add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
-           add srt (sortBy farthestFst cafs)
-             where
-               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
-                                   (Nothing, Nothing) -> EQ
-                                   (Nothing, Just _)  -> LT
-                                   (Just _,  Nothing) -> GT
-                                   (Just d, Just d')  -> compare d' d
-               add srt [] = srt
-               add srt@(TopSRT {next_elt = next}) (caf : rst) =
-                 case cafOffset srt caf of
-                   Just ix -> if next - ix > maxBmpSize dflags then
-                                add (addCAF caf srt) rst
-                              else srt
-                   Nothing -> add (addCAF caf srt) rst
-     (topSRT, subSRTs) <- sub_srt topSRT cafs
-     let (sub_tbls, blockSRTs) = subSRTs
-     return (topSRT, sub_tbls, blockSRTs)
-
--- Construct an SRT bitmap.
--- Adapted from simpleStg/SRT.hs, which expects Id's.
-procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
-                UniqSM (Maybe CmmDecl, C_SRT)
-procpointSRT _ _ _ [] =
- return (Nothing, NoC_SRT)
-procpointSRT dflags top_srt top_table entries =
- do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
-    return (top, srt)
-  where
-    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
-    sorted_ints = sort ints
-    offset = head sorted_ints
-    bitmap_entries = map (subtract offset) sorted_ints
-    len = P.last bitmap_entries + 1
-    bitmap = intsToBitmap dflags len bitmap_entries
-
-maxBmpSize :: DynFlags -> Int
-maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-
--- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
-to_SRT dflags top_srt off len bmp
-  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
-  = do id <- getUniqueM
-       let srt_desc_lbl = mkLargeSRTLabel id
-           section = Section RelocatableReadOnlyData srt_desc_lbl
-           tbl = CmmData section $
-                   Statics srt_desc_lbl $ map CmmStaticLit
-                     ( cmmLabelOffW dflags top_srt off
-                     : mkWordCLit dflags (fromIntegral len)
-                     : map (mkStgWordCLit dflags) bmp)
-       return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
-  | otherwise
-  = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
-        -- The fromIntegral converts to StgHalfWord
-
--- Gather CAF info for a procedure, but only if the procedure
--- doesn't have a static closure.
--- (If it has a static closure, it will already have an SRT to
---  keep its CAFs live.)
--- Any procedure referring to a non-static CAF c must keep live
--- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
-localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
-localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
-  case topInfoTable proc of
-    Just (CmmInfoTable { cit_rep = rep })
-      | not (isStaticRep rep) && not (isStackRep rep)
-      -> (cafs, Just (toClosureLbl top_l))
-    _other -> (cafs, Nothing)
-  where
-    cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
-
--- Once we have the local CAF sets for some (possibly) mutually
--- recursive functions, we can create an environment mapping
--- each function to its set of CAFs. Note that a CAF may
--- be a reference to a function. If that function f does not have
--- a static closure, then we need to refer specifically
--- to the set of CAFs used by f. Of course, the set of CAFs
--- used by f must be included in the local CAF sets that are input to
--- this function. To minimize lookup time later, we return
--- the environment with every reference to f replaced by its set of CAFs.
--- To do this replacement efficiently, we gather strongly connected
--- components, then we sort the components in topological order.
-mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
-mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
-  where
-        addToTop env (AcyclicSCC (l, cafset)) =
-          Map.insert l (flatten env cafset) env
-        addToTop env (CyclicSCC nodes) =
-          let (lbls, cafsets) = unzip nodes
-              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
-          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
-
-        g = stronglyConnCompFromEdgedVerticesOrd
-              [ DigraphNode (l,cafs) l (Set.elems cafs)
-              | (cafs, Just l) <- localCAFs ]
-
-flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
-flatten env cafset = foldSet (lookup env) Set.empty cafset
-  where
-      lookup env caf cafset' =
-          case Map.lookup caf env of
-             Just cafs -> foldSet Set.insert cafset' cafs
-             Nothing   -> Set.insert caf cafset'
-
-bundle :: Map CLabel CAFSet
-       -> (CAFEnv, CmmDecl)
-       -> (CAFSet, Maybe CLabel)
-       -> (LabelMap CAFSet, CmmDecl)
-bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
-  = ( mapMapWithKey get_cafs (info_tbls infos), decl )
- where
-  entry = g_entry g
-
-  entry_cafs
-    | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
-    | otherwise        = flatten flatmap closure_cafs
-
-  get_cafs l _
-    | l == entry = entry_cafs
-    | Just info <- mapLookup l env = flatten flatmap info
-    | otherwise  = Set.empty
-    -- the label might not be in the env if the code corresponding to
-    -- this info table was optimised away (perhaps because it was
-    -- unreachable).  In this case it doesn't matter what SRT we
-    -- infer, since the info table will not appear in the generated
-    -- code.  See #9329.
-
-bundle _flatmap (_, decl) _
-  = ( mapEmpty, decl )
-
-
-flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
-flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
-   where
-     zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
-     localCAFs = unzipWith localCAFInfo zipped
-     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
-
-doSRTs :: DynFlags
-       -> TopSRT
-       -> [(CAFEnv, [CmmDecl])]
-       -> IO (TopSRT, [CmmDecl])
-
-doSRTs dflags topSRT tops
-  = do
-     let caf_decls = flattenCAFSets tops
-     us <- mkSplitUniqSupply 'u'
-     let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
-     return (topSRT', reverse gs' {- Note [reverse gs] -})
-  where
-    setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
-       (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
-       let decl' = updInfoSRTs srt_env decl
-       return (topSRT, decl': srt_tables ++ rst)
-    setSRT (topSRT, rst) (_, decl) =
-      return (topSRT, decl : rst)
-
-buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
-          -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
-buildSRTs dflags top_srt caf_map
-  = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
-  where
-  doOne (top_srt, decls, srt_env) (l, cafs)
-    = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
-         return ( top_srt, maybeToList mb_decl ++ decls
-                , mapInsert l srt srt_env )
-
-{-
-- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
-- The one corresponding to g_entry is the closure info table, the
-  rest are continuations.
-- Each one needs an SRT.
-- We get the CAFSet for each one from the CAFEnv
-- flatten gives us
-    [(LabelMap CAFSet, CmmDecl)]
--
--}
 
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+  { thisModule :: Module
+    -- ^ Current module being compiled. Required for calling labelDynamic.
+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+    -- ^ previous SRTs we've emitted, so we can de-duplicate.
+    -- Used to implement the [Common] optimisation.
+  , flatSRTs :: Map SRTEntry (Set SRTEntry)
+    -- ^ The reverse mapping, so that we can remove redundant
+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
+    -- points to [c,d], we can omit c and emit [a,b].
+    -- Used to implement the [Filter] optimisation.
+  }
+instance Outputable ModuleSRTInfo where
+  ppr ModuleSRTInfo{..} =
+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
 
-{- Note [reverse gs]
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+  ModuleSRTInfo
+    { thisModule = mod
+    , dedupSRTs = Map.empty
+    , flatSRTs = Map.empty }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+  table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT.  We need to make a
+  label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
 
-   It is important to keep the code blocks in the same order,
-   otherwise binary sizes get slightly bigger.  I'm not completely
-   sure why this is, perhaps the assembler generates bigger jump
-   instructions for forward refs.  --SDM
 -}
 
-updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl
-updInfoSRTs srt_env (CmmProc top_info top_l live g) =
-  CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
-  where updInfoTbl l info_tbl
-             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
-updInfoSRTs _ t = t
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+--   where the label is
+--   - the info label for a continuation or dynamic closure
+--   - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
+getLabelledBlocks (CmmData _ _) = []
+getLabelledBlocks (CmmProc top_info _ _ _) =
+  [ (blockId, mkCAFLabel (cit_lbl info))
+  | (blockId, info) <- mapToList (info_tbls top_info)
+  , let rep = cit_rep info
+  , not (isStaticRep rep) || not (isThunkRep rep)
+  ]
+
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr graph) graph
+ where
+  labelledBlocks = concatMap getLabelledBlocks decls
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+--  - we never shortcut a reference to a CAF to the contents of its
+--    SRT, since the point of SRTs is to keep CAFs alive.
+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+--    instead we generate their SRTs after everything else.
+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs cafEnv decls =
+  [ (g_entry g, mkCAFLabel topLbl, cafs)
+  | CmmProc top_info topLbl _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , let rep = cit_rep info
+  , isStaticRep rep && isThunkRep rep
+  , Just cafs <- [mapLookup (g_entry g) cafEnv]
+  ]
+
+
+-- | Get the list of blocks that correspond to the entry points for
+-- FUN_STATIC closures.  These are the blocks for which if we have an
+-- SRT we can merge it with the static closure. [FUN]
+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
+getStaticFuns decls =
+  [ (g_entry g, lbl)
+  | CmmProc top_info _ _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , Just (id, _) <- [cit_clo info]
+  , let rep = cit_rep info
+  , isStaticRep rep && isFunRep rep
+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+  ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+--   - closures with singleton SRTs resolve to their single entry
+--   - closures with larger SRTs map to the label for that SRT
+--   - CAFs must not map to anything!
+--   - if a labels maps to Nothing, we found that this label's SRT
+--     is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF srtMap lbl@(CAFLabel l) =
+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+  :: DynFlags
+  -> ModuleSRTInfo
+  -> [(CAFEnv, [CmmDecl])]
+  -> IO (ModuleSRTInfo, [CmmDecl])
+
+doSRTs dflags moduleSRTInfo tops = do
+  us <- mkSplitUniqSupply 'u'
+
+  -- Ignore the original grouping of decls, and combine all the
+  -- CAFEnvs into a single CAFEnv.
+  let (cafEnvs, declss) = unzip tops
+      cafEnv = mapUnions cafEnvs
+      decls = concat declss
+      staticFuns = mapFromList (getStaticFuns decls)
+
+  -- Put the decls in dependency order. Why? So that we can implement
+  -- [Inline] and [Filter].  If we need to refer to an SRT that has
+  -- a single entry, we use the entry itself, which means that we
+  -- don't need to generate the singleton SRT in the first place.  But
+  -- to do this we need to process blocks before things that depend on
+  -- them.
+  let
+    sccs = depAnalSRTs cafEnv decls
+    cafsWithSRTs = getCAFs cafEnv decls
+
+  -- On each strongly-connected group of decls, construct the SRT
+  -- closures and the SRT fields for info tables.
+  let result ::
+        [ ( [CmmDecl]              -- generated SRTs
+          , [(Label, CLabel)]      -- SRT fields for info tables
+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+          ) ]
+      ((result, _srtMap), moduleSRTInfo') =
+        initUs_ us $
+        flip runStateT moduleSRTInfo $
+        flip runStateT Map.empty $ do
+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
+          return (nonCAFs ++ cAFs)
+
+      (declss, pairs, funSRTs) = unzip3 result
+
+  -- Next, update the info tables with the SRTs
+  let
+    srtFieldMap = mapFromList (concat pairs)
+    funSRTMap = mapFromList (concat funSRTs)
+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
+
+  return (moduleSRTInfo', concat declss ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+  :: DynFlags
+  -> LabelMap CLabel           -- which blocks are static function entry points
+  -> SCC (Label, CAFLabel, Set CAFLabel)
+  -> StateT SRTMap
+        (StateT ModuleSRTInfo UniqSM)
+        ( [CmmDecl]              -- generated SRTs
+        , [(Label, CLabel)]      -- SRT fields for info tables
+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+        )
+
+doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
+  oneSRT dflags staticFuns [l] [cafLbl] False cafs
+
+doSCC dflags staticFuns (CyclicSCC nodes) = do
+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
+  let (blockids, lbls, cafsets) = unzip3 nodes
+      cafs = Set.unions cafsets
+  oneSRT dflags staticFuns blockids lbls False cafs
+
+
+{- Note [recursive SRTs]
+
+If the dependency analyser has found us a recursive group of
+declarations, then we build a single SRT for the whole group, on the
+grounds that everything in the group is reachable from everything
+else, so we lose nothing by having a single SRT.
+
+However, there are a couple of wrinkles to be aware of.
+
+* The Set CAFLabel for this SRT will contain labels in the group
+itself. The SRTMap will therefore not contain entries for these labels
+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
+can just remove recursive references from the Set CAFLabel before
+generating the SRT - the SRT will still contain all the CAFLabels that
+we need to refer to from this group's SRT.
+
+* That is, EXCEPT for static function closures. For the same reason
+described in Note [Invalid optimisation: shortcutting], we cannot omit
+references to static function closures.
+  - But, since we will merge the SRT with one of the static function
+    closures (see [FUN]), we can omit references to *that* static
+    function closure from the SRT.
+-}
+
+-- | Build an SRT for a set of blocks
+oneSRT
+  :: DynFlags
+  -> LabelMap CLabel            -- which blocks are static function entry points
+  -> [Label]                    -- blocks in this set
+  -> [CAFLabel]                 -- labels for those blocks
+  -> Bool                       -- True <=> this SRT is for a CAF
+  -> Set CAFLabel               -- SRT for this set
+  -> StateT SRTMap
+       (StateT ModuleSRTInfo UniqSM)
+       ( [CmmDecl]                    -- SRT objects we built
+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
+       )
+
+oneSRT dflags staticFuns blockids lbls isCAF cafs = do
+  srtMap <- get
+  topSRT <- lift get
+  let
+    -- Can we merge this SRT with a FUN_STATIC closure?
+    (maybeFunClosure, otherFunLabels) =
+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+        [] -> (Nothing, [])
+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)
+
+    -- Remove recursive references from the SRT, except for (all but
+    -- one of the) static functions. See Note [recursive SRTs].
+    nonRec = cafs `Set.difference`
+      Set.fromList lbls `Set.difference` Set.fromList otherFunLabels
+
+    -- First resolve all the CAFLabels to SRTEntries
+    -- Implements the [Inline] optimisation.
+    resolved =
+       Set.fromList $
+       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))
+
+    -- The set of all SRTEntries in SRTs that we refer to from here.
+    allBelow =
+      Set.unions [ lbls | caf <- Set.toList resolved
+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+    -- Remove SRTEntries that are also in an SRT that we refer to.
+    -- Implements the [Filter] optimisation.
+    filtered = Set.difference resolved allBelow
+
+  srtTrace "oneSRT:"
+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
+
+  let
+    isStaticFun = isJust maybeFunClosure
+
+    -- For a label without a closure (e.g. a continuation), we must
+    -- update the SRTMap for the label to point to a closure. It's
+    -- important that we don't do this for static functions or CAFs,
+    -- see Note [Invalid optimisation: shortcutting].
+    updateSRTMap srtEntry =
+      when (not isCAF && not isStaticFun) $ do
+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+        put (Map.union newSRTMap srtMap)
+
+    this_mod = thisModule topSRT
+
+  case Set.toList filtered of
+    [] -> do
+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
+      updateSRTMap Nothing
+      return ([], [], [])
+
+    -- [Inline] - when we have only one entry there is no need to
+    -- build an SRT object at all, instead we put the singleton SRT
+    -- entry in the info table.
+    [one@(SRTEntry lbl)]
+      | -- Info tables refer to SRTs by offset (as noted in the section
+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+        -- when dynamic linking is used we cannot guarantee that the offset
+        -- between the SRT and the info table will fit in the offset field.
+        -- Consequently we build a singleton SRT in in this case.
+        not (labelDynamic dflags this_mod lbl)
+
+        -- MachO relocations can't express offsets between compilation units at
+        -- all, so we are always forced to build a singleton SRT in this case.
+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+             || isLocalCLabel this_mod lbl) -> do
+
+        -- If we have a static function closure, then it becomes the
+        -- SRT object, and everything else points to it. (the only way
+        -- we could have multiple labels here is if this is a
+        -- recursive group, see Note [recursive SRTs])
+        case maybeFunClosure of
+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])
+            where
+              withLabels =
+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)
+                | b <- blockids ]
+          Nothing -> do
+            updateSRTMap (Just one)
+            return ([], map (,lbl) blockids, [])
+
+    cafList ->
+      -- Check whether an SRT with the same entries has been emitted already.
+      -- Implements the [Common] optimisation.
+      case Map.lookup filtered (dedupSRTs topSRT) of
+        Just srtEntry@(SRTEntry srtLbl)  -> do
+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
+          updateSRTMap (Just srtEntry)
+          return ([], map (,srtLbl) blockids, [])
+        Nothing -> do
+          -- No duplicates: we have to build a new SRT object
+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
+          (decls, funSRTs, srtEntry) <-
+            case maybeFunClosure of
+              Just (fun,block) ->
+                return ( [], [(block, cafList)], SRTEntry fun )
+              Nothing -> do
+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
+                return (decls, [], entry)
+          updateSRTMap (Just srtEntry)
+          let allBelowThis = Set.union allBelow filtered
+              oldFlatSRTs = flatSRTs topSRT
+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+          lift (put (topSRT { dedupSRTs = newDedupSRTs
+                            , flatSRTs = newFlatSRTs }))
+          let SRTEntry lbl = srtEntry
+          return (decls, map (,lbl) blockids, funSRTs)
+
+
+-- | build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+   :: DynFlags
+   -> [SRTEntry]
+   -> UniqSM
+        ( [CmmDecl]    -- The SRT object(s)
+        , SRTEntry     -- label to use in the info table
+        )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain dflags cafSet =
+  case splitAt mAX_SRT_SIZE cafSet of
+    (these, []) -> do
+      (decl,lbl) <- buildSRT dflags these
+      return ([decl], lbl)
+    (these,those) -> do
+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+      return (decl:rest, lbl)
+  where
+    mAX_SRT_SIZE = 16
+
+
+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
+buildSRT dflags refs = do
+  id <- getUniqueM
+  let
+    lbl = mkSRTLabel id
+    srt_n_info = mkSRTInfoLabel (length refs)
+    fields =
+      mkStaticClosure dflags srt_n_info dontCareCCS
+        [ CmmLabel lbl | SRTEntry lbl <- refs ]
+        [] -- no padding
+        [mkIntCLit dflags 0] -- link field
+        [] -- no saved info
+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
+
+
+-- | Update info tables with references to their SRTs. Also generate
+-- static closures, splicing in SRT fields as necessary.
+updInfoSRTs
+  :: DynFlags
+  -> LabelMap CLabel               -- SRT labels for each block
+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
+  -> CmmDecl
+  -> [CmmDecl]
+
+updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
+  | otherwise = [ proc ]
+  where
+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+    updInfoTbl l info_tbl
+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }
+
+    -- Generate static closures [FUN].  Note that this also generates
+    -- static closures for thunks (CAFs), because it's easier to treat
+    -- them uniformly in the code generator.
+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
+    maybeStaticClosure
+      | Just info_tbl@CmmInfoTable{..} <-
+           mapLookup (g_entry g) (info_tbls top_info)
+      , Just (id, ccs) <- cit_clo
+      , isStaticRep cit_rep =
+        let
+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+            Nothing ->
+              -- if we don't add SRT entries to this closure, then we
+              -- want to set the srt field in its info table as usual
+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+              (info_tbl { cit_rep = new_rep }, res)
+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
+            srtEntries
+          new_rep = case cit_rep of
+             HeapRep sta ptrs nptrs ty ->
+               HeapRep sta (ptrs + length srtEntries) nptrs ty
+             _other -> panic "maybeStaticFun"
+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+        in
+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
+      | otherwise = Nothing
+
+updInfoSRTs _ _ _ t = [t]
+
+
+srtTrace :: String -> SDoc -> b -> b
+-- srtTrace = pprTrace
+srtTrace _ _ b = b
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 440ee5634f..e1067e9519 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 module CmmCallConv (
   ParamLocation(..),
   assignArgumentsPos,
@@ -7,7 +5,7 @@ module CmmCallConv (
   realArgRegsCover
 ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import CmmExpr
 import SMRep
@@ -129,9 +127,10 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
       assign_stk offset assts (r:rs)
         = assign_stk off' ((r, StackParam off') : assts) rs
         where w    = typeWidth (arg_ty r)
-              size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size
               off' = offset + size
-              word_size = wORD_SIZE dflags
+              -- Stack arguments always take a whole number of words, we never
+              -- pack them unlike constructor fields.
+              size = roundUpToWords dflags (widthInBytes w)
 
 -----------------------------------------------------------------------------
 -- Local information about the registers available
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 3c23e70b8c..1af9a84028 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -1,17 +1,19 @@
-{-# LANGUAGE GADTs, BangPatterns #-}
+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+
 module CmmCommonBlockElim
   ( elimCommonBlocks
   )
 where
 
 
+import GhcPrelude hiding (iterate, succ, unzip, zip)
+
 import BlockId
 import Cmm
 import CmmUtils
 import CmmSwitch (eqSwitchTargetWith)
 import CmmContFlowOpt
 -- import PprCmm ()
-import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl.Block
 import Hoopl.Graph
@@ -23,11 +25,11 @@ import qualified Data.List as List
 import Data.Word
 import qualified Data.Map as M
 import Outputable
-import UniqFM
-import UniqDFM
 import qualified TrieMap as TM
+import UniqFM
 import Unique
 import Control.Arrow (first, second)
+import Data.List (foldl')
 
 -- -----------------------------------------------------------------------------
 -- Eliminate common blocks
@@ -62,7 +64,11 @@ elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
      env = iterate mapEmpty blocks_with_key
-     groups = groupByInt hash_block (postorderDfs g)
+     -- The order of blocks doesn't matter here. While we could use
+     -- revPostorder which drops unreachable blocks this is done in
+     -- ContFlowOpt already which runs before this pass. So we use
+     -- toBlockList since it is faster.
+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
      blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
 
 -- Invariant: The blocks in the list are pairwise distinct
@@ -90,6 +96,8 @@ iterate subst blocks
     subst' = subst `mapUnion` new_substs
     updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
 
+-- Combine two lists of blocks.
+-- While they are internally distinct they can still share common blocks.
 mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
 mergeBlocks subst existing new = go new
   where
@@ -165,14 +173,14 @@ hash_block block =
         hash_lit (CmmVec ls) = hash_list hash_lit ls
         hash_lit (CmmLabel _) = 119 -- ugh
         hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
-        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
+        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i
         hash_lit (CmmBlock _) = 191 -- ugh
         hash_lit (CmmHighStackMark) = cvt 313
 
         hash_tgt (ForeignTarget e _) = hash_e e
         hash_tgt (PrimTarget _) = 31 -- lots of these
 
-        hash_list f = foldl (\z x -> f x + z) (0::Word32)
+        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
 
         cvt = fromInteger . toInteger
 
@@ -208,7 +216,7 @@ eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
   = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
                    (CmmUnsafeForeignCall t2 r2 a2)
-  = t1 == t2 && r1 == r2 && and (zipWith (eqExprWith eqBid) a1 a2)
+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2
 eqMiddleWith _ _ _ = False
 
 eqExprWith :: (BlockId -> BlockId -> Bool)
@@ -223,7 +231,7 @@ eqExprWith eqBid = eq
   CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
   _e1                `eq` _e2                = False
 
-  xs `eqs` ys = and (zipWith eq xs ys)
+  xs `eqs` ys = eqListWith eq xs ys
 
   eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
   eqLit l1 l2 = l1 == l2
@@ -246,7 +254,7 @@ eqBlockBodyWith eqBid block block'
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
-        equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
+        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&
                 eqLastWith eqBid l l'
 
 
@@ -265,6 +273,11 @@ eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
 eqMaybeWith _ Nothing Nothing = True
 eqMaybeWith _ _ _ = False
 
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
+eqListWith _ []       []       = True
+eqListWith _ _        _        = False
+
 -- | Given a block map, ensure that all "target" blocks are covered by
 -- the same ticks as the respective "source" blocks. This not only
 -- means copying ticks, but also adjusting tick scopes where
@@ -275,8 +288,8 @@ copyTicks env g
   | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
   where -- Reverse block merge map
         blockMap = toBlockMap g
-        revEnv = mapFoldWithKey insertRev M.empty env
-        insertRev k x = M.insertWith (const (k:)) x [k]
+        revEnv = mapFoldlWithKey insertRev M.empty env
+        insertRev m k x = M.insertWith (const (k:)) x [k] m
         -- Copy ticks and scopes into the given block
         copyTo block = case M.lookup (entryLabel block) revEnv of
           Nothing -> block
@@ -289,17 +302,21 @@ copyTicks env g
              foldr blockCons code (map CmmTick ticks)
 
 -- Group by [Label]
-groupByLabel :: [(Key, a)] -> [(Key, [a])]
-groupByLabel = go (TM.emptyTM :: TM.ListMap UniqDFM a)
-  where
-    go !m [] = TM.foldTM (:) m []
-    go !m ((k,v) : entries) = go (TM.alterTM k' adjust m) entries
-      where k' = map getUnique k
-            adjust Nothing       = Just (k,[v])
-            adjust (Just (_,vs)) = Just (k,v:vs)
-
+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
+groupByLabel =
+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
+    where
+      go !m [] = TM.foldTM (:) m []
+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
+        where --k' = map (getKey . getUnique) k
+              adjust Nothing       = Just (k,[v])
+              adjust (Just (_,vs)) = Just (k,v:vs)
 
 groupByInt :: (a -> Int) -> [a] -> [[a]]
 groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
-  -- See Note [Unique Determinism and code generation]
-  where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)
+   -- See Note [Unique Determinism and code generation]
+  where
+    go m x = alterUFM addEntry m (f x)
+      where
+        addEntry xs = Just $! maybe [x] (x:) xs
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 219b68e42a..92dd7abba5 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 module CmmContFlowOpt
     ( cmmCfgOpts
@@ -8,6 +9,8 @@ module CmmContFlowOpt
     )
 where
 
+import GhcPrelude hiding (succ, unzip, zip)
+
 import Hoopl.Block
 import Hoopl.Collections
 import Hoopl.Graph
@@ -21,7 +24,6 @@ import Panic
 import Util
 
 import Control.Monad
-import Prelude hiding (succ, unzip, zip)
 
 
 -- Note [What is shortcutting]
@@ -53,7 +55,7 @@ import Prelude hiding (succ, unzip, zip)
 --
 -- This optimisation does three things:
 --
---   - If a block finishes in an unconditonal branch to another block
+--   - If a block finishes in an unconditional branch to another block
 --     and that is the only jump to that block we concatenate the
 --     destination block at the end of the current one.
 --
@@ -171,11 +173,10 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
        | otherwise
        = (entry_id, shortcut_map)
 
-     -- blocks is a list of blocks in DFS postorder, while blockmap is
-     -- a map of blocks. We process each element from blocks and update
-     -- blockmap accordingly
-     blocks = postorderDfs g
-     blockmap = foldr addBlock emptyBody blocks
+     -- blocks are sorted in reverse postorder, but we want to go from the exit
+     -- towards beginning, so we use foldr below.
+     blocks = revPostorder g
+     blockmap = foldl' (flip addBlock) emptyBody blocks
 
      -- Accumulator contains three components:
      --  * map of blocks in a graph
@@ -194,7 +195,7 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
      maybe_concat :: CmmBlock
                   -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
                   -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-     maybe_concat block (blocks, shortcut_map, backEdges)
+     maybe_concat block (!blocks, !shortcut_map, !backEdges)
         -- If:
         --   (1) current block ends with unconditional branch to b' and
         --   (2) it has exactly one predecessor (namely, current block)
@@ -252,8 +253,8 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
         -- unconditional jump to a block that can be shortcut.
         | Nothing <- callContinuation_maybe last
         = let oldSuccs = successors last
-              newSuccs = successors swapcond_last
-          in ( mapInsert bid (blockJoinTail head swapcond_last) blocks
+              newSuccs = successors rewrite_last
+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
              , shortcut_map
              , if oldSuccs == newSuccs
                then backEdges
@@ -281,34 +282,58 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
                    Just b | Just dest <- canShortcut b -> dest
                    _otherwise -> l
 
-          -- For a conditional, we invert the conditional if that would make it
-          -- more likely that the branch-not-taken case becomes a fallthrough.
-          -- This helps the native codegen a little bit, and probably has no
-          -- effect on LLVM.  It's convenient to do it here, where we have the
-          -- information about predecessors.
-          swapcond_last
+          rewrite_last
+            -- Sometimes we can get rid of the conditional completely.
+            | CmmCondBranch _cond t f _l <- shortcut_last
+            , t == f
+            = CmmBranch t
+
+            -- See Note [Invert Cmm conditionals]
             | CmmCondBranch cond t f l <- shortcut_last
-            , likelyFalse l
-            , numPreds f > 1
-            , hasOnePredecessor t
+            , hasOnePredecessor t -- inverting will make t a fallthrough
+            , likelyTrue l || (numPreds f > 1)
             , Just cond' <- maybeInvertCmmExpr cond
             = CmmCondBranch cond' f t (invertLikeliness l)
 
             | otherwise
             = shortcut_last
 
-          likelyFalse (Just False) = True
-          likelyFalse Nothing      = True
-          likelyFalse _            = False
+          likelyTrue (Just True)   = True
+          likelyTrue _             = False
 
-          invertLikeliness (Just b)     = Just (not b)
-          invertLikeliness Nothing      = Nothing
+          invertLikeliness :: Maybe Bool -> Maybe Bool
+          invertLikeliness         = fmap not
 
           -- Number of predecessors for a block
           numPreds bid = mapLookup bid backEdges `orElse` 0
 
           hasOnePredecessor b = numPreds b == 1
 
+{-
+  Note [Invert Cmm conditionals]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  The native code generator always produces jumps to the true branch.
+  Falling through to the false branch is however faster. So we try to
+  arrange for that to happen.
+  This means we invert the condition if:
+  * The likely path will become a fallthrough.
+  * We can't guarantee a fallthrough for the false branch but for the
+    true branch.
+
+  In some cases it's faster to avoid inverting when the false branch is likely.
+  However determining when that is the case is neither easy nor cheap so for
+  now we always invert as this produces smaller binaries and code that is
+  equally fast on average. (On an i7-6700K)
+
+  TODO:
+  There is also the edge case when both branches have multiple predecessors.
+  In this case we could assume that we will end up with a jump for BOTH
+  branches. In this case it might be best to put the likely path in the true
+  branch especially if there are large numbers of predecessors as this saves
+  us the jump thats not taken. However I haven't tested this and as of early
+  2018 we almost never generate cmm where this would apply.
+-}
+
 -- Functions for incrementing and decrementing number of predecessors. If
 -- decrementing would set the predecessor count to 0, we remove entry from the
 -- map.
@@ -406,14 +431,14 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
              -- Remove any info_tbls for unreachable
 
      keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
-     keep_used bs = mapFoldWithKey keep mapEmpty bs
+     keep_used bs = mapFoldlWithKey keep mapEmpty bs
 
-     keep :: Label -> CmmInfoTable -> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
-     keep l i env | l `setMember` used_lbls = mapInsert l i env
+     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
+     keep env l i | l `setMember` used_lbls = mapInsert l i env
                   | otherwise               = env
 
      used_blocks :: [CmmBlock]
-     used_blocks = postorderDfs g
+     used_blocks = revPostorder g
 
      used_lbls :: LabelSet
-     used_lbls = foldr (setInsert . entryLabel) setEmpty used_blocks
+     used_lbls = setFromList $ map entryLabel used_blocks
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index bb610a0b88..d129d601f4 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -10,7 +9,10 @@ module CmmExpr
     , CmmReg(..), cmmRegType
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
-    , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
+    , GlobalReg(..), isArgReg, globalRegType
+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , node, baseReg
     , VGcPtr(..)
 
     , DefinerOfRegs, UserOfRegs
@@ -28,6 +30,8 @@ module CmmExpr
     )
 where
 
+import GhcPrelude
+
 import BlockId
 import CLabel
 import CmmMachOp
@@ -37,7 +41,6 @@ import Outputable (panic)
 import Unique
 
 import Data.Set (Set)
-import Data.List
 import qualified Data.Set as Set
 
 -----------------------------------------------------------------------------
@@ -184,7 +187,14 @@ data CmmLit
         -- Don't use it at all unless tablesNextToCode.
         -- It is also used inside the NCG during when generating
         -- position-independent code.
-  | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
+  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset
+        -- In an expression, the width just has the effect of MO_SS_Conv
+        -- from wordWidth to the desired width.
+        --
+        -- In a static literal, the supported Widths depend on the
+        -- architecture: wordWidth is supported on all
+        -- architectures. Additionally W32 is supported on x86_64 when
+        -- using the small memory model.
 
   | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
         -- Invariant: must be a continuation BlockId
@@ -217,7 +227,7 @@ cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l
                                             else panic "cmmLitType: CmmVec"
 cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl
 cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl
-cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
+cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width
 cmmLitType dflags (CmmBlock _)         = bWord dflags
 cmmLitType dflags (CmmHighStackMark)   = bWord dflags
 
@@ -549,12 +559,18 @@ instance Ord GlobalReg where
    compare _ EagerBlackholeInfo = GT
 
 -- convenient aliases
-baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
 baseReg = CmmGlobal BaseReg
 spReg = CmmGlobal Sp
 hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
 spLimReg = CmmGlobal SpLim
 nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
 
 node :: GlobalReg
 node = VanillaReg 1 VGcPtr
diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
index eda031e840..2e2da5d305 100644
--- a/compiler/cmm/CmmImplementSwitchPlans.hs
+++ b/compiler/cmm/CmmImplementSwitchPlans.hs
@@ -4,6 +4,8 @@ module CmmImplementSwitchPlans
   )
 where
 
+import GhcPrelude
+
 import Hoopl.Block
 import BlockId
 import Cmm
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index e849c810ef..43cba2526d 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -34,6 +34,8 @@ module CmmInfo (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Cmm
 import CmmUtils
 import CLabel
@@ -43,6 +45,7 @@ import Stream (Stream)
 import qualified Stream
 import Hoopl.Collections
 
+import Platform
 import Maybes
 import DynFlags
 import Panic
@@ -60,7 +63,8 @@ mkEmptyContInfoTable info_lbl
   = CmmInfoTable { cit_lbl  = info_lbl
                  , cit_rep  = mkStackRep []
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
             -> IO (Stream IO RawCmmGroup ())
@@ -186,7 +190,7 @@ mkInfoTableContents dflags
 
   | StackRep frame <- smrep
   = do { (prof_lits, prof_data) <- mkProfLits dflags prof
-       ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
        ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
        ; let
              std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
@@ -199,7 +203,7 @@ mkInfoTableContents dflags
   | HeapRep _ ptrs nonptrs closure_type <- smrep
   = do { let layout  = packIntsCLit dflags ptrs nonptrs
        ; (prof_lits, prof_data) <- mkProfLits dflags prof
-       ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
        ; (mb_srt_field, mb_layout, extra_bits, ct_data)
                                 <- mk_pieces closure_type srt_label
        ; let std_info = mkStdInfoTable dflags prof_lits
@@ -209,20 +213,22 @@ mkInfoTableContents dflags
        ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
   where
     mk_pieces :: ClosureTypeInfo -> [CmmLit]
-              -> UniqSM ( Maybe StgHalfWord  -- Override the SRT field with this
-                        , Maybe CmmLit       -- Override the layout field with this
+              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
+                        , Maybe CmmLit  -- Override the layout field with this
                         , [CmmLit]           -- "Extra bits" for info table
                         , [RawCmmDecl])      -- Auxiliary data decls
     mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
       = do { (descr_lit, decl) <- newStringLit con_descr
-           ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
+           ; return ( Just (CmmInt (fromIntegral con_tag)
+                                   (halfWordWidth dflags))
                     , Nothing, [descr_lit], [decl]) }
 
     mk_pieces Thunk srt_label
       = return (Nothing, Nothing, srt_label, [])
 
     mk_pieces (ThunkSelector offset) _no_srt
-      = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+      = return (Just (CmmInt 0 (halfWordWidth dflags)),
+                Just (mkWordCLit dflags (fromIntegral offset)), [], [])
          -- Layout known (one free var); we use the layout field for offset
 
     mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
@@ -233,8 +239,9 @@ mkInfoTableContents dflags
       = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
            ; let fun_type | null liveness_data = aRG_GEN
                           | otherwise          = aRG_GEN_BIG
-                 extra_bits = [ packIntsCLit dflags fun_type arity
-                              , srt_lit, liveness_lit, slow_entry ]
+                 extra_bits = [ packIntsCLit dflags fun_type arity ]
+                           ++ (if inlineSRT dflags then [] else [ srt_lit ])
+                           ++ [ liveness_lit, slow_entry ]
            ; return (Nothing, Nothing, extra_bits, liveness_data) }
       where
         slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
@@ -253,12 +260,24 @@ packIntsCLit dflags a b = packHalfWordsCLit dflags
 
 
 mkSRTLit :: DynFlags
-         -> C_SRT
+         -> CLabel
+         -> Maybe CLabel
          -> ([CmmLit],    -- srt_label, if any
-             StgHalfWord) -- srt_bitmap
-mkSRTLit dflags NoC_SRT                = ([], toStgHalfWord dflags 0)
-mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
+             CmmLit)      -- srt_bitmap
+mkSRTLit dflags info_lbl (Just lbl)
+  | inlineSRT dflags
+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+
 
+-- | Is the SRT offset field inline in the info table on this platform?
+--
+-- See the section "Referring to an SRT from the info table" in
+-- Note [SRTs] in CmmBuildInfoTables.hs
+inlineSRT :: DynFlags -> Bool
+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
+  && tablesNextToCode dflags
 
 -------------------------------------------------------------------------
 --
@@ -290,10 +309,10 @@ makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
 
 makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
   | tablesNextToCode dflags
-  = CmmLabelDiffOff lbl info_lbl 0
+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
 makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
   | tablesNextToCode dflags
-  = CmmLabelDiffOff lbl info_lbl off
+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
 makeRelativeRefTo _ _ lit = lit
 
 
@@ -366,23 +385,23 @@ mkStdInfoTable
    :: DynFlags
    -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
    -> Int               -- Closure RTS tag
-   -> StgHalfWord       -- SRT length
+   -> CmmLit            -- SRT length
    -> CmmLit            -- layout field
    -> [CmmLit]
 
-mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
  =      -- Parallel revertible-black hole field
     prof_info
         -- Ticky info (none at present)
         -- Debug info (none at present)
- ++ [layout_lit, type_lit]
+ ++ [layout_lit, tag, srt]
 
  where
     prof_info
         | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
         | otherwise = []
 
-    type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
+    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
 
 -------------------------------------------------------------------------
 --
@@ -415,9 +434,19 @@ srtEscape dflags = toStgHalfWord dflags (-1)
 --
 -------------------------------------------------------------------------
 
+-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
+-- enabled.
+wordAligned :: DynFlags -> CmmExpr -> CmmExpr
+wordAligned dflags e
+  | gopt Opt_AlignmentSanitisation dflags
+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+  | otherwise
+  = e
+
 closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes a closure pointer and returns the info table pointer
-closureInfoPtr dflags e = CmmLoad e (bWord dflags)
+closureInfoPtr dflags e =
+    CmmLoad (wordAligned dflags e) (bWord dflags)
 
 entryCode :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info pointer (the first word of a closure)
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 4151aa0c4e..1d6c209953 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -1,8 +1,10 @@
-{-# LANGUAGE BangPatterns, CPP, RecordWildCards, GADTs #-}
+{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
 module CmmLayoutStack (
        cmmLayoutStack, setInfoTableStackMap
   ) where
 
+import GhcPrelude hiding ((<*>))
+
 import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
 import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
 
@@ -35,11 +37,7 @@ import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
-import Data.List (nub)
-
-import Prelude hiding ((<*>))
-
-#include "HsVersions.h"
+import Data.List (nub, foldl')
 
 {- Note [Stack Layout]
 
@@ -246,7 +244,7 @@ cmmLayoutStack dflags procpoints entry_args
     -- We need liveness info. Dead assignments are removed later
     -- by the sinking pass.
     let liveness = cmmLocalLiveness dflags graph
-        blocks = postorderDfs graph
+        blocks = revPostorder graph
 
     (final_stackmaps, _final_high_sp, new_blocks) <-
           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
@@ -324,7 +322,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
        --    Sp = Sp + sp_off -- Sp adjustment goes here
        --    last1            -- the last node
        --
-       let middle_pre = blockToList $ foldl blockSnoc middle0 middle1
+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
 
        let final_blocks =
                manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
@@ -579,15 +577,8 @@ makeFixupBlock dflags sp0 l stack tscope assigs
   | otherwise = do
     tmp_lbl <- newBlockId
     let sp_off = sp0 - sm_sp stack
-        maybeAddUnwind block
-          | debugLevel dflags > 0
-          = block `blockSnoc` CmmUnwind [(Sp, Just unwind_val)]
-          | otherwise
-          = block
-          where unwind_val = cmmOffset dflags (CmmReg spReg) (sm_sp stack)
         block = blockJoin (CmmEntry tmp_lbl tscope)
-                          (  maybeAddSpAdj dflags sp_off
-                           $ maybeAddUnwind
+                          ( maybeAddSpAdj dflags sp0 sp_off
                            $ blockFromList assigs )
                           (CmmBranch l)
     return (tmp_lbl, [block])
@@ -853,28 +844,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
     adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
     adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
 
-    -- Add unwind pseudo-instruction at the beginning of each block to
-    -- document Sp level for debugging
-    add_initial_unwind block
-      | debugLevel dflags > 0
-      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
-      | otherwise
-      = block
-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
-
-    -- Add unwind pseudo-instruction right before the Sp adjustment
-    -- if there is one.
-    add_adj_unwind block
-      | debugLevel dflags > 0
-      , sp_off /= 0
-      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
-      | otherwise
-      = block
-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
-
-    final_middle = maybeAddSpAdj dflags sp_off
-                 . add_adj_unwind
-                 . add_initial_unwind
+    final_middle = maybeAddSpAdj dflags sp0 sp_off
                  . blockFromList
                  . map adj_pre_sp
                  . elimStackStores stack0 stackmaps area_off
@@ -893,11 +863,33 @@ getAreaOff stackmaps (Young l) =
     Nothing -> pprPanic "getAreaOff" (ppr l)
 
 
-maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
-maybeAddSpAdj _      0      block = block
-maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj
+maybeAddSpAdj
+  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj dflags sp0 sp_off block =
+  add_initial_unwind $ add_adj_unwind $ adj block
   where
-    adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
+    adj block
+      | sp_off /= 0
+      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+      | otherwise = block
+    -- Add unwind pseudo-instruction at the beginning of each block to
+    -- document Sp level for debugging
+    add_initial_unwind block
+      | debugLevel dflags > 0
+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+
+    -- Add unwind pseudo-instruction right after the Sp adjustment
+    -- if there is one.
+    add_adj_unwind block
+      | debugLevel dflags > 0
+      , sp_off /= 0
+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
 
 {- Note [SP old/young offsets]
 
@@ -920,7 +912,7 @@ arguments.
 areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
 
 areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
-  = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
+  = cmmOffset dflags spExpr (sp_old - area_off area - n)
     -- Replace (CmmStackSlot area n) with an offset from Sp
 
 areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
@@ -1090,7 +1082,7 @@ insertReloads dflags stackmap live =
      [ CmmAssign (CmmLocal reg)
                  -- This cmmOffset basically corresponds to manifesting
                  -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
-                 (CmmLoad (cmmOffset dflags (CmmReg spReg) (sp_off - reg_off))
+                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
                           (localRegType reg))
      | (reg, reg_off) <- stackSlotRegs stackmap
      , reg `elemRegSet` live
@@ -1143,7 +1135,7 @@ lowerSafeForeignCall dflags block
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
     id <- newTemp (bWord dflags)
-    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
+    new_base <- newTemp (cmmRegType dflags baseReg)
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
     save_state_code <- saveThreadState dflags
     load_state_code <- loadThreadState dflags
@@ -1154,7 +1146,7 @@ lowerSafeForeignCall dflags block
         resume  = mkMiddle (callResumeThread new_base id) <*>
                   -- Assign the result to BaseReg: we
                   -- might now have a different Capability!
-                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
+                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
                   caller_load <*>
                   load_state_code
 
@@ -1169,7 +1161,7 @@ lowerSafeForeignCall dflags block
         -- different.  Hence we continue by jumping to the top stack frame,
         -- not by jumping to succ.
         jump = CmmCall { cml_target    = entryCode dflags $
-                                         CmmLoad (CmmReg spReg) (bWord dflags)
+                                         CmmLoad spExpr (bWord dflags)
                        , cml_cont      = Just succ
                        , cml_args_regs = regs
                        , cml_args      = widthInBytes (wordWidth dflags)
@@ -1199,7 +1191,7 @@ callSuspendThread dflags id intrbl =
   CmmUnsafeForeignCall
        (ForeignTarget (foreignLbl (fsLit "suspendThread"))
         (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
-       [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
+       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
 
 callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
 callResumeThread new_base id =
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index 82f7bee965..691ca5eb28 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -22,6 +22,8 @@ module CmmLex (
    CmmToken(..), cmmlex,
   ) where
 
+import GhcPrelude
+
 import CmmExpr
 
 import Lexer
@@ -97,6 +99,10 @@ $white_no_nl+           ;
   "&&"                  { kw CmmT_BoolAnd }
   "||"                  { kw CmmT_BoolOr }
 
+  "True"                { kw CmmT_True  }
+  "False"               { kw CmmT_False }
+  "likely"              { kw CmmT_likely}
+
   P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }
   R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }
   F@decimal             { global_regN FloatReg }
@@ -178,6 +184,9 @@ data CmmToken
   | CmmT_Int       Integer
   | CmmT_Float     Rational
   | CmmT_EOF
+  | CmmT_False
+  | CmmT_True
+  | CmmT_likely
   deriving (Show)
 
 -- -----------------------------------------------------------------------------
@@ -264,7 +273,10 @@ reservedWordsFM = listToUFM $
         ( "b512",               CmmT_bits512 ),
         ( "f32",                CmmT_float32 ),
         ( "f64",                CmmT_float64 ),
-        ( "gcptr",              CmmT_gcptr )
+        ( "gcptr",              CmmT_gcptr ),
+        ( "likely",             CmmT_likely),
+        ( "True",               CmmT_True  ),
+        ( "False",              CmmT_False )
         ]
 
 tok_decimal span buf len
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 64b4400378..3224bb8cab 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -10,6 +10,8 @@ module CmmLint (
     cmmLint, cmmLintGraph
   ) where
 
+import GhcPrelude
+
 import Hoopl.Block
 import Hoopl.Collections
 import Hoopl.Graph
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 944a9e394e..f340c32c8a 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -12,6 +12,8 @@ module CmmLive
     )
 where
 
+import GhcPrelude
+
 import DynFlags
 import BlockId
 import Cmm
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index d736f14bfc..c5e9d9bf27 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 module CmmMachOp
     ( MachOp(..)
     , pprMachOp, isCommutableMachOp, isAssociativeMachOp
@@ -28,7 +26,7 @@ module CmmMachOp
    )
 where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import CmmType
 import Outputable
@@ -136,9 +134,12 @@ data MachOp
   -- Floating point vector operations
   | MO_VF_Add  Length Width
   | MO_VF_Sub  Length Width
-  | MO_VF_Neg  Length Width             -- unary -
+  | MO_VF_Neg  Length Width      -- unary negation
   | MO_VF_Mul  Length Width
   | MO_VF_Quot Length Width
+
+  -- Alignment check (for -falignment-sanitisation)
+  | MO_AlignmentCheck Int Width
   deriving (Eq, Show)
 
 pprMachOp :: MachOp -> SDoc
@@ -417,6 +418,8 @@ machOpResultType dflags mop tys =
     MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)
     MO_VF_Quot l w      -> cmmVec l (cmmFloat w)
     MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)
+
+    MO_AlignmentCheck _ _ -> ty1
   where
     (ty1:_) = tys
 
@@ -507,6 +510,8 @@ machOpArgReps dflags op =
     MO_VF_Quot _ r      -> [r,r]
     MO_VF_Neg  _ r      -> [r]
 
+    MO_AlignmentCheck _ r -> [r]
+
 -----------------------------------------------------------------------------
 -- CallishMachOp
 -----------------------------------------------------------------------------
@@ -526,6 +531,9 @@ data CallishMachOp
   | MO_F64_Asin
   | MO_F64_Acos
   | MO_F64_Atan
+  | MO_F64_Asinh
+  | MO_F64_Acosh
+  | MO_F64_Atanh
   | MO_F64_Log
   | MO_F64_Exp
   | MO_F64_Fabs
@@ -540,6 +548,9 @@ data CallishMachOp
   | MO_F32_Asin
   | MO_F32_Acos
   | MO_F32_Atan
+  | MO_F32_Asinh
+  | MO_F32_Acosh
+  | MO_F32_Atanh
   | MO_F32_Log
   | MO_F32_Exp
   | MO_F32_Fabs
@@ -551,6 +562,7 @@ data CallishMachOp
   | MO_U_QuotRem Width
   | MO_U_QuotRem2 Width
   | MO_Add2      Width
+  | MO_AddWordC  Width
   | MO_SubWordC  Width
   | MO_AddIntC   Width
   | MO_SubIntC   Width
@@ -575,8 +587,11 @@ data CallishMachOp
   | MO_Memcpy Int
   | MO_Memset Int
   | MO_Memmove Int
+  | MO_Memcmp Int
 
   | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext Width
   | MO_Clz Width
   | MO_Ctz Width
 
@@ -607,6 +622,7 @@ callishMachOpHints op = case op of
   MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])
   MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])
   MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])
   _            -> ([],[])
   -- empty lists indicate NoHint
 
@@ -616,4 +632,5 @@ machOpMemcpyishAlign op = case op of
   MO_Memcpy  align -> Just align
   MO_Memset  align -> Just align
   MO_Memmove align -> Just align
+  MO_Memcmp  align -> Just align
   _                -> Nothing
diff --git a/compiler/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
index fc66bf5928..f3b4441a9b 100644
--- a/compiler/cmm/CmmMonad.hs
+++ b/compiler/cmm/CmmMonad.hs
@@ -7,16 +7,15 @@
 -- The parser for C-- requires access to a lot more of the 'DynFlags',
 -- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
 -----------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
 module CmmMonad (
     PD(..)
   , liftP
   ) where
 
+import GhcPrelude
+
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 
 import DynFlags
 import Lexer
@@ -32,12 +31,10 @@ instance Applicative PD where
 
 instance Monad PD where
   (>>=) = thenPD
-  fail = failPD
+  fail = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail PD where
   fail = failPD
-#endif
 
 liftP :: P a -> PD a
 liftP (P f) = PD $ \_ s -> f s
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index f452b0b3f5..286b1e306c 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -22,6 +22,8 @@ module CmmNode (
      CmmTickScope(..), isTickSubScope, combineTickScopes,
   ) where
 
+import GhcPrelude hiding (succ)
+
 import CodeGen.Platform
 import CmmExpr
 import CmmSwitch
@@ -38,7 +40,6 @@ import Hoopl.Graph
 import Hoopl.Label
 import Data.Maybe
 import Data.List (tails,sortBy)
-import Prelude hiding (succ)
 import Unique (nonDetCmpUnique)
 import Util
 
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 3cb28217f2..e837d29783 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -1,10 +1,6 @@
-{-# LANGUAGE CPP #-}
-
 -- The default iteration limit is a bit too low for the definitions
 -- in this module.
-#if __GLASGOW_HASKELL__ >= 800
 {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-#endif
 
 -----------------------------------------------------------------------------
 --
@@ -21,7 +17,7 @@ module CmmOpt (
         cmmMachOpFoldM
  ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import CmmUtils
 import Cmm
@@ -357,35 +353,51 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
         MO_U_Quot rep
            | Just p <- exactLog2 n ->
                  Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+        MO_U_Rem rep
+           | Just _ <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
         MO_S_Quot rep
            | Just p <- exactLog2 n,
-             CmmReg _ <- x ->   -- We duplicate x below, hence require
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                Just (cmmMachOpFold dflags (MO_S_Shr rep)
+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
+        MO_S_Rem rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
                                 -- it is a reg.  FIXME: remove this restriction.
-                -- shift right is not the same as quot, because it rounds
-                -- to minus infinity, whereasq quot rounds toward zero.
-                -- To fix this up, we add one less than the divisor to the
-                -- dividend if it is a negative number.
-                --
-                -- to avoid a test/jump, we use the following sequence:
-                --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
-                --      x2 = y & (divisor-1)
-                --      result = (x+x2) >>= log2(divisor)
-                -- this could be done a bit more simply using conditional moves,
-                -- but we're processor independent here.
-                --
-                -- we optimise the divide by 2 case slightly, generating
-                --      x1 = x >> word_size-1  (unsigned)
-                --      return = (x + x1) >>= log2(divisor)
-                let
-                    bits = fromIntegral (widthInBits rep) - 1
-                    shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
-                    x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
-                    x2 = if p == 1 then x1 else
-                         CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
-                    x3 = CmmMachOp (MO_Add rep) [x, x2]
-                in
-                Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)])
+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
+                Just (cmmMachOpFold dflags (MO_Sub rep)
+                    [x, cmmMachOpFold dflags (MO_And rep)
+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
         _ -> Nothing
+  where
+    -- In contrast with unsigned integers, for signed ones
+    -- shift right is not the same as quot, because it rounds
+    -- to minus infinity, whereas quot rounds toward zero.
+    -- To fix this up, we add one less than the divisor to the
+    -- dividend if it is a negative number.
+    --
+    -- to avoid a test/jump, we use the following sequence:
+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
+    --      x2 = y & (divisor-1)
+    --      result = x + x2
+    -- this could be done a bit more simply using conditional moves,
+    -- but we're processor independent here.
+    --
+    -- we optimise the divide by 2 case slightly, generating
+    --      x1 = x >> word_size-1  (unsigned)
+    --      return = x + x1
+    signedQuotRemHelper :: Width -> Integer -> CmmExpr
+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
+      where
+        bits = fromIntegral (widthInBits rep) - 1
+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
+        x2 = if p == 1 then x1 else
+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
 
 -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
 -- Unfortunately this needs a unique supply because x might not be a
@@ -410,14 +422,6 @@ That's what the constant-folding operations on comparison operators do above.
 -- -----------------------------------------------------------------------------
 -- Utils
 
-isLit :: CmmExpr -> Bool
-isLit (CmmLit _) = True
-isLit _          = False
-
-isComparisonExpr :: CmmExpr -> Bool
-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
-isComparisonExpr _                  = False
-
 isPicReg :: CmmExpr -> Bool
 isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
 isPicReg _ = False
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index e2fe593b5d..8cc988383e 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -200,6 +200,8 @@ necessary to the stack to accommodate it (e.g. 2).
 {
 module CmmParse ( parseCmmFile ) where
 
+import GhcPrelude
+
 import StgCmmExtCode
 import CmmCallConv
 import StgCmmProf
@@ -297,6 +299,10 @@ import qualified Data.Map as M
         '&&'    { L _ (CmmT_BoolAnd) }
         '||'    { L _ (CmmT_BoolOr) }
 
+        'True'  { L _ (CmmT_True ) }
+        'False' { L _ (CmmT_False) }
+        'likely'{ L _ (CmmT_likely)}
+
         'CLOSURE'       { L _ (CmmT_CLOSURE) }
         'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
         'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
@@ -396,8 +402,6 @@ statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
         | static statics                { $1 : $2 }
     
--- Strings aren't used much in the RTS HC code, so it doesn't seem
--- worth allowing inline strings.  C-- doesn't allow them anyway.
 static  :: { CmmParse [CmmStatic] }
         : type expr ';' { do e <- $2;
                              return [CmmStaticLit (getLit e)] }
@@ -466,7 +470,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               []) }
         
         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
@@ -482,7 +486,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               []) }
                 -- we leave most of the fields zero here.  This is only used
                 -- to generate the BCO info table in the RTS at the moment.
@@ -500,7 +504,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
                               []) }
 
                      -- If profiling is on, this string gets duplicated,
@@ -517,7 +521,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
@@ -528,7 +532,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmRetLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
@@ -538,12 +542,12 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       live <- sequence $7
                       let prof = NoProfilingInfo
                           -- drop one for the info pointer
-                          bitmap = mkLiveness dflags (map Just (drop 1 live))
+                          bitmap = mkLiveness dflags (drop 1 live)
                           rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
                       return (mkCmmRetLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                               live) }
 
 body    :: { CmmParse () }
@@ -627,10 +631,10 @@ stmt    :: { CmmParse () }
                 { doCall $2 [] $4 }
         | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
                 { doCall $6 $2 $8 }
-        | 'if' bool_expr 'goto' NAME
-                { do l <- lookupLabel $4; cmmRawIf $2 l }
-        | 'if' bool_expr '{' body '}' else      
-                { cmmIfThenElse $2 (withSourceNote $3 $5 $4) $6 }
+        | 'if' bool_expr cond_likely 'goto' NAME
+                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
+        | 'if' bool_expr cond_likely '{' body '}' else
+                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
         | 'push' '(' exprs0 ')' maybe_body
                 { pushStackFrame $3 $5 }
         | 'reserve' expr '=' lreg maybe_body
@@ -719,6 +723,12 @@ else    :: { CmmParse () }
         : {- empty -}                   { return () }
         | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
 
+cond_likely :: { Maybe Bool }
+        : '(' 'likely' ':' 'True'  ')'  { Just True  }
+        | '(' 'likely' ':' 'False' ')'  { Just False }
+        | {- empty -}                   { Nothing }
+
+
 -- we have to write this out longhand so that Happy's precedence rules
 -- can kick in.
 expr    :: { CmmParse CmmExpr }
@@ -992,6 +1002,7 @@ callishMachOps = listToUFM $
         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
         ( "memset", memcpyLikeTweakArgs MO_Memset ),
         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
 
         ("prefetch0", (,) $ MO_Prefetch_Data 0),
         ("prefetch1", (,) $ MO_Prefetch_Data 1),
@@ -1003,6 +1014,16 @@ callishMachOps = listToUFM $
         ( "popcnt32", (,) $ MO_PopCnt W32 ),
         ( "popcnt64", (,) $ MO_PopCnt W64 ),
 
+        ( "pdep8",  (,) $ MO_Pdep W8  ),
+        ( "pdep16", (,) $ MO_Pdep W16 ),
+        ( "pdep32", (,) $ MO_Pdep W32 ),
+        ( "pdep64", (,) $ MO_Pdep W64 ),
+
+        ( "pext8",  (,) $ MO_Pext W8  ),
+        ( "pext16", (,) $ MO_Pext W16 ),
+        ( "pext32", (,) $ MO_Pext W32 ),
+        ( "pext64", (,) $ MO_Pext W64 ),
+
         ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
         ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
         ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
@@ -1276,11 +1297,11 @@ data BoolExpr
 
 -- ToDo: smart constructors which simplify the boolean expression.
 
-cmmIfThenElse cond then_part else_part = do
+cmmIfThenElse cond then_part else_part likely = do
      then_id <- newBlockId
      join_id <- newBlockId
      c <- cond
-     emitCond c then_id
+     emitCond c then_id likely
      else_part
      emit (mkBranch join_id)
      emitLabel then_id
@@ -1288,38 +1309,38 @@ cmmIfThenElse cond then_part else_part = do
      -- fall through to join
      emitLabel join_id
 
-cmmRawIf cond then_id = do
+cmmRawIf cond then_id likely = do
     c <- cond
-    emitCond c then_id
+    emitCond c then_id likely
 
 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 -- branching to true_id if so, and falling through otherwise.
-emitCond (BoolTest e) then_id = do
+emitCond (BoolTest e) then_id likely = do
   else_id <- newBlockId
-  emit (mkCbranch e then_id else_id Nothing)
+  emit (mkCbranch e then_id else_id likely)
   emitLabel else_id
-emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
   | Just op' <- maybeInvertComparison op
-  = emitCond (BoolTest (CmmMachOp op' args)) then_id
-emitCond (BoolNot e) then_id = do
+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
+emitCond (BoolNot e) then_id likely = do
   else_id <- newBlockId
-  emitCond e else_id
+  emitCond e else_id likely
   emit (mkBranch then_id)
   emitLabel else_id
-emitCond (e1 `BoolOr` e2) then_id = do
-  emitCond e1 then_id
-  emitCond e2 then_id
-emitCond (e1 `BoolAnd` e2) then_id = do
+emitCond (e1 `BoolOr` e2) then_id likely = do
+  emitCond e1 then_id likely
+  emitCond e2 then_id likely
+emitCond (e1 `BoolAnd` e2) then_id likely = do
         -- we'd like to invert one of the conditionals here to avoid an
         -- extra branch instruction, but we can't use maybeInvertComparison
         -- here because we can't look too closely at the expression since
         -- we're in a loop.
   and_id <- newBlockId
   else_id <- newBlockId
-  emitCond e1 and_id
+  emitCond e1 and_id likely
   emit (mkBranch else_id)
   emitLabel and_id
-  emitCond e2 then_id
+  emitCond e2 then_id likely
   emitLabel else_id
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index bc827dfe87..77598a4b09 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -7,6 +7,8 @@ module CmmPipeline (
   cmmPipeline
 ) where
 
+import GhcPrelude
+
 import Cmm
 import CmmLint
 import CmmBuildInfoTables
@@ -30,21 +32,22 @@ import Platform
 -- | Top level driver for C-- pipeline
 -----------------------------------------------------------------------------
 
-cmmPipeline  :: HscEnv -- Compilation env including
-                       -- dynamic flags: -dcmm-lint -ddump-cmm-cps
-             -> TopSRT     -- SRT table and accumulating list of compiled procs
-             -> CmmGroup             -- Input C-- with Procedures
-             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
+cmmPipeline
+ :: HscEnv -- Compilation env including
+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
+ -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> CmmGroup             -- Input C-- with Procedures
+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
 
-cmmPipeline hsc_env topSRT prog =
+cmmPipeline hsc_env srtInfo prog =
   do let dflags = hsc_dflags hsc_env
 
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
-     (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
      dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
 
-     return (topSRT, cmms)
+     return (srtInfo, cmms)
 
 
 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
@@ -103,7 +106,7 @@ cpsTop hsc_env proc =
                      Opt_D_dump_cmm_sink "Sink assignments"
 
        ------------- CAF analysis ----------------------------------------------
-       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
        dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
 
        g <- if splitting_proc_points
@@ -163,7 +166,7 @@ cpsTop hsc_env proc =
                              || -- Note [inconsistent-pic-reg]
                                 usingInconsistentPicReg
         usingInconsistentPicReg
-           = case (platformArch platform, platformOS platform, gopt Opt_PIC dflags)
+           = case (platformArch platform, platformOS platform, positionIndependent dflags)
              of   (ArchX86, OSDarwin, pic) -> pic
                   (ArchPPC, OSDarwin, pic) -> pic
                   _                        -> False
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 2e2c22c10d..bef8f384b8 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -8,7 +8,7 @@ module CmmProcPoint
     )
 where
 
-import Prelude hiding (last, unzip, succ, zip)
+import GhcPrelude hiding (last, unzip, succ, zip)
 
 import DynFlags
 import BlockId
@@ -19,7 +19,7 @@ import CmmUtils
 import CmmInfo
 import CmmLive
 import CmmSwitch
-import Data.List (sortBy)
+import Data.List (sortBy, foldl')
 import Maybes
 import Control.Monad
 import Outputable
@@ -178,9 +178,9 @@ procPointLattice = DataflowLattice unreached add_to
 --
 -- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
 callProcPoints      :: CmmGraph -> ProcPointSet
-callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
-  where add :: CmmBlock -> LabelSet -> LabelSet
-        add b set = case lastNode b of
+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
+  where add :: LabelSet -> CmmBlock -> LabelSet
+        add set b = case lastNode b of
                       CmmCall {cml_cont = Just k} -> setInsert k set
                       CmmForeignCall {succ=k}     -> setInsert k set
                       _ -> set
@@ -190,17 +190,17 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
 -- Given the set of successors of calls (which must be proc-points)
 -- figure out the minimal set of necessary proc-points
 minimalProcPointSet platform callProcPoints g
-  = extendPPSet platform g (postorderDfs g) callProcPoints
+  = extendPPSet platform g (revPostorder g) callProcPoints
 
 extendPPSet
     :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
 extendPPSet platform g blocks procPoints =
     let env = procPointAnalysis procPoints g
-        add block pps = let id = entryLabel block
+        add pps block = let id = entryLabel block
                         in  case mapLookup id env of
                               Just ProcPoint -> setInsert id pps
                               _ -> pps
-        procPoints' = foldGraphBlocks add setEmpty g
+        procPoints' = foldlGraphBlocks add setEmpty g
         newPoints = mapMaybe ppSuccessor blocks
         newPoint  = listToMaybe newPoints
         ppSuccessor b =
@@ -242,11 +242,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                   (CmmProc (TopInfo {info_tbls = info_tbls})
                            top_l _ g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
-     let addBlock
-             :: CmmBlock
+     let add_block
+             :: LabelMap (LabelMap CmmBlock)
+             -> CmmBlock
              -> LabelMap (LabelMap CmmBlock)
-             -> LabelMap (LabelMap CmmBlock)
-         addBlock b graphEnv =
+         add_block graphEnv b =
            case mapLookup bid procMap of
              Just ProcPoint -> add graphEnv bid bid b
              Just (ReachedBy set) ->
@@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                          regSetToList $
                          expectJust "ppLiveness" $ mapLookup pp liveness
 
-     graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g
+     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
 
      -- Build a map from proc point BlockId to pairs of:
      --  * Labels for their new procedures
@@ -275,12 +275,13 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      let add_label map pp = mapInsert pp lbls map
            where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
                       | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
-                                                    Just (toInfoLbl block_lbl))
-                      where block_lbl = blockLbl pp
+                                                    Just info_table_lbl)
+                      where block_lbl      = blockLbl pp
+                            info_table_lbl = infoTblLbl pp
 
          procLabels :: LabelMap (CLabel, Maybe CLabel)
-         procLabels = foldl add_label mapEmpty
-                            (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+         procLabels = foldl' add_label mapEmpty
+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
 
      -- In each new graph, add blocks jumping off to the new procedures,
      -- and replace branches to procpoints with branches to the jump-off blocks
@@ -301,7 +302,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
              -> UniqSM (LabelMap CmmGraph)
          add_jumps newGraphEnv (ppId, blockEnv) =
            do let needed_jumps = -- find which procpoints we currently branch to
-                    mapFold add_if_branch_to_pp [] blockEnv
+                    mapFoldr add_if_branch_to_pp [] blockEnv
                   add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
                   add_if_branch_to_pp block rst =
                     case lastNode block of
@@ -329,7 +330,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                   -- replace branches to procpoints with branches to jumps
                   blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
                   -- add the jump blocks to the graph
-                  blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
               let g' = ofBlockMap ppId blockEnv'''
               -- pprTrace "g' pre jumps" (ppr g') $ do
               return (mapInsert ppId g' newGraphEnv)
@@ -372,9 +373,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      -- call sites.  Here, we sort them in reverse order -- it gets
      -- reversed later.
      let (_, block_order) =
-             foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)
-                   (postorderDfs g)
-         add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
+             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
+                   (revPostorder g)
+         add_block_num (i, map) block =
+           (i + 1, mapInsert (entryLabel block) i map)
          sort_fn (bid, _) (bid', _) =
            compare (expectJust "block_order" $ mapLookup bid  block_order)
                    (expectJust "block_order" $ mapLookup bid' block_order)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 517605b9ff..6317cfe929 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -3,6 +3,8 @@ module CmmSink (
      cmmSink
   ) where
 
+import GhcPrelude
+
 import Cmm
 import CmmOpt
 import CmmLive
@@ -15,13 +17,31 @@ import CodeGen.Platform
 import Platform (isARM, platformArch)
 
 import DynFlags
+import Unique
 import UniqFM
 import PprCmm ()
 
+import qualified Data.IntSet as IntSet
 import Data.List (partition)
 import qualified Data.Set as Set
 import Data.Maybe
 
+-- Compact sets for membership tests of local variables.
+
+type LRegSet = IntSet.IntSet
+
+emptyLRegSet :: LRegSet
+emptyLRegSet = IntSet.empty
+
+nullLRegSet :: LRegSet -> Bool
+nullLRegSet = IntSet.null
+
+insertLRegSet :: LocalReg -> LRegSet -> LRegSet
+insertLRegSet l = IntSet.insert (getKey (getUnique l))
+
+elemLRegSet :: LocalReg -> LRegSet -> Bool
+elemLRegSet l = IntSet.member (getKey (getUnique l))
+
 -- -----------------------------------------------------------------------------
 -- Sinking and inlining
 
@@ -152,7 +172,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
   liveness = cmmLocalLiveness dflags graph
   getLive l = mapFindWithDefault Set.empty l liveness
 
-  blocks = postorderDfs graph
+  blocks = revPostorder graph
 
   join_pts = findJoinPoints blocks
 
@@ -213,7 +233,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
 
             live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
 
-      final_middle = foldl blockSnoc middle' dropped_last
+      final_middle = foldl' blockSnoc middle' dropped_last
 
       sunk' = mapUnion sunk $
                  mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
@@ -323,7 +343,7 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
       (dropped, as') = dropAssignmentsSimple dflags
                           (\a -> conflicts dflags a node2) as1
 
-      block' = foldl blockSnoc block dropped `blockSnoc` node2
+      block' = foldl' blockSnoc block dropped `blockSnoc` node2
 
 
 --
@@ -397,7 +417,7 @@ tryToInline
       , Assignments             -- Remaining assignments
       )
 
-tryToInline dflags live node assigs = go usages node [] assigs
+tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
  where
   usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
   usages = foldLocalRegsUsed dflags addUsage emptyUFM node
@@ -420,7 +440,7 @@ tryToInline dflags live node assigs = go usages node [] assigs
         inline_and_keep    = keep inl_node -- inline the assignment, keep it
 
         keep node' = (final_node, a : rest')
-          where (final_node, rest') = go usages' node' (l:skipped) rest
+          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest
                 usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)
                                             usages rhs
                 -- we must not inline anything that is mentioned in the RHS
@@ -428,7 +448,7 @@ tryToInline dflags live node assigs = go usages node [] assigs
                 -- usages of the regs on the RHS to 2.
 
         cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]
-                        || l `elem` skipped
+                        || l `elemLRegSet` skipped
                         || not (okToInline dflags rhs node)
 
         l_usages = lookupUFM usages l
@@ -437,13 +457,7 @@ tryToInline dflags live node assigs = go usages node [] assigs
         occurs_once = not l_live && l_usages == Just 1
         occurs_none = not l_live && l_usages == Nothing
 
-        inl_node = case mapExpDeep inl_exp node of
-                     -- See Note [Improving conditionals]
-                     CmmCondBranch (CmmMachOp (MO_Ne w) args)
-                                   ti fi l
-                           -> CmmCondBranch (cmmMachOpFold dflags (MO_Eq w) args)
-                                            fi ti l
-                     node' -> node'
+        inl_node = improveConditional (mapExpDeep inl_exp node)
 
         inl_exp :: CmmExpr -> CmmExpr
         -- inl_exp is where the inlining actually takes place!
@@ -454,22 +468,43 @@ tryToInline dflags live node assigs = go usages node [] assigs
         inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
         inl_exp other = other
 
-{- Note [Improving conditionals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given
-  CmmCondBranch ((a >## b) != 1) t f
-where a,b, are Floats, the constant folder /cannot/ turn it into
-  CmmCondBranch (a <=## b) t f
-because comparison on floats are not invertible
-(see CmmMachOp.maybeInvertComparison).
 
-What we want instead is simply to reverse the true/false branches thus
+{- Note [improveConditional]
+
+cmmMachOpFold tries to simplify conditionals to turn things like
+  (a == b) != 1
+into
+  (a != b)
+but there's one case it can't handle: when the comparison is over
+floating-point values, we can't invert it, because floating-point
+comparisons aren't invertible (because of NaNs).
+
+But we *can* optimise this conditional by swapping the true and false
+branches. Given
   CmmCondBranch ((a >## b) != 1) t f
--->
+we can turn it into
   CmmCondBranch (a >## b) f t
 
-And we do that right here in tryToInline, just as we do cmmMachOpFold.
+So here we catch conditionals that weren't optimised by cmmMachOpFold,
+and apply above transformation to eliminate the comparison against 1.
+
+It's tempting to just turn every != into == and then let cmmMachOpFold
+do its thing, but that risks changing a nice fall-through conditional
+into one that requires two jumps. (see swapcond_last in
+CmmContFlowOpt), so instead we carefully look for just the cases where
+we can eliminate a comparison.
 -}
+improveConditional :: CmmNode O x -> CmmNode O x
+improveConditional
+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
+  | neLike mop, isComparisonExpr x
+  = CmmCondBranch x f t (fmap not l)
+  where
+    neLike (MO_Ne _) = True
+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike _ = False
+improveConditional other = other
 
 -- Note [dependent assignments]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -519,11 +554,11 @@ And we do that right here in tryToInline, just as we do cmmMachOpFold.
 addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
 addUsage m r = addToUFM_C (+) m r 1
 
-regsUsedIn :: [LocalReg] -> CmmExpr -> Bool
-regsUsedIn [] _ = False
+regsUsedIn :: LRegSet -> CmmExpr -> Bool
+regsUsedIn ls _ | nullLRegSet ls = False
 regsUsedIn ls e = wrapRecExpf f e False
-  where f (CmmReg (CmmLocal l))      _ | l `elem` ls = True
-        f (CmmRegOff (CmmLocal l) _) _ | l `elem` ls = True
+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True
+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True
         f _ z = z
 
 -- we don't inline into CmmUnsafeForeignCall if the expression refers
@@ -721,7 +756,7 @@ loadAddr dflags e w =
   case e of
    CmmReg r       -> regAddr dflags r 0 w
    CmmRegOff r i  -> regAddr dflags r i w
-   _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem
+   _other | regUsedIn dflags spReg e -> StackMem
           | otherwise -> AnyMem
 
 regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs
index b0ca4be762..ce779465e3 100644
--- a/compiler/cmm/CmmSwitch.hs
+++ b/compiler/cmm/CmmSwitch.hs
@@ -11,6 +11,8 @@ module CmmSwitch (
      createSwitchPlan,
   ) where
 
+import GhcPrelude
+
 import Outputable
 import DynFlags
 import Hoopl.Label (Label)
@@ -107,7 +109,7 @@ data SwitchTargets =
         (M.Map Integer Label)      -- The branches
     deriving (Show, Eq)
 
--- | The smart constructr mkSwitchTargets normalises the map a bit:
+-- | The smart constructor mkSwitchTargets normalises the map a bit:
 --  * No entries outside the range
 --  * No entries equal to the default
 --  * No default if all elements have explicit values
@@ -249,6 +251,68 @@ data SwitchPlan
 --     findSingleValues
 --  5. The thus collected pieces are assembled to a balanced binary tree.
 
+{-
+  Note [Two alts + default]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Discussion and a bit more info at #14644
+
+When dealing with a switch of the form:
+switch(e) {
+  case 1: goto l1;
+  case 3000: goto l2;
+  default: goto ldef;
+}
+
+If we treat it as a sparse jump table we would generate:
+
+if (e > 3000) //Check if value is outside of the jump table.
+    goto ldef;
+else {
+    if (e < 3000) { //Compare to upper value
+        if(e != 1) //Compare to remaining value
+            goto ldef;
+          else
+            goto l2;
+    }
+    else
+        goto l1;
+}
+
+Instead we special case this to :
+
+if (e==1) goto l1;
+else if (e==3000) goto l2;
+else goto l3;
+
+This means we have:
+* Less comparisons for: 1,<3000
+* Unchanged for 3000
+* One more for >3000
+
+This improves code in a few ways:
+* One comparison less means smaller code which helps with cache.
+* It exchanges a taken jump for two jumps no taken in the >range case.
+  Jumps not taken are cheaper (See Agner guides) making this about as fast.
+* For all other cases the first range check is removed making it faster.
+
+The end result is that the change is not measurably slower for the case
+>3000 and faster for the other cases.
+
+This makes running this kind of match in an inner loop cheaper by 10-20%
+depending on the data.
+In nofib this improves wheel-sieve1 by 4-9% depending on problem
+size.
+
+We could also add a second conditional jump after the comparison to
+keep the range check like this:
+    cmp 3000, rArgument
+    jg <default>
+    je <branch 2>
+While this is fairly cheap it made no big difference for the >3000 case
+and slowed down all other cases making it not worthwhile.
+-}
+
 
 -- | Does the target support switch out of the box? Then leave this to the
 -- target!
@@ -264,13 +328,16 @@ createSwitchPlan :: SwitchTargets -> SwitchPlan
 createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
     | [(x, l)] <- M.toList m
     = IfEqual x l (Unconditionally defLabel)
--- And another common case, matching booleans
+-- And another common case, matching "booleans"
 createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)
-    | [(x1, l1), (x2,l2)] <- M.toAscList m
-    , x1 == lo
-    , x2 == hi
-    , x1 + 1 == x2
+    | [(x1, l1), (_x2,l2)] <- M.toAscList m
+    --Checking If |range| = 2 is enough if we have two unique literals
+    , hi - lo == 1
     = IfEqual x1 l1 (Unconditionally l2)
+-- See Note [Two alts + default]
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x1, l1), (x2,l2)] <- M.toAscList m
+    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))
 createSwitchPlan (SwitchTargets signed range mbdef m) =
     -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $
     plan
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index 4abbeaf0c1..97b181a243 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 module CmmType
     ( CmmType   -- Abstract
     , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord
@@ -29,7 +27,8 @@ module CmmType
    )
 where
 
-#include "HsVersions.h"
+
+import GhcPrelude
 
 import DynFlags
 import FastString
@@ -71,7 +70,7 @@ instance Outputable CmmCat where
 -- Why is CmmType stratified?  For native code generation,
 -- most of the time you just want to know what sort of register
 -- to put the thing in, and for this you need to know how
--- many bits thing has and whether it goes in a floating-point
+-- many bits thing has, and whether it goes in a floating-point
 -- register.  By contrast, the distinction between GcPtr and
 -- GcNonPtr is of interest to only a few parts of the code generator.
 
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 74524c997f..42d64842e2 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, RankNTypes #-}
+{-# LANGUAGE GADTs, RankNTypes #-}
 
 -----------------------------------------------------------------------------
 --
@@ -35,7 +35,10 @@ module CmmUtils(
         cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
         cmmToWord,
 
-        isTrivialCmmExpr, hasNoGlobalRegs,
+        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
+
+        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
+        currentTSOExpr, currentNurseryExpr, cccsExpr,
 
         -- Statics
         blankWord,
@@ -53,16 +56,16 @@ module CmmUtils(
         -- * Operations that probably don't belong here
         modifyGraph,
 
-        ofBlockMap, toBlockMap, insertBlock,
+        ofBlockMap, toBlockMap,
         ofBlockList, toBlockList, bodyToBlockList,
         toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
-        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
 
         -- * Ticks
         blockTicks
   ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import TyCon    ( PrimRep(..), PrimElemRep(..) )
 import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
@@ -73,11 +76,9 @@ import BlockId
 import CLabel
 import Outputable
 import DynFlags
-import Util
 import CodeGen.Platform
 
 import Data.Word
-import Data.Maybe
 import Data.Bits
 import Hoopl.Graph
 import Hoopl.Label
@@ -252,8 +253,8 @@ cmmRegOff reg byte_off = CmmRegOff reg byte_off
 cmmOffsetLit :: CmmLit -> Int -> CmmLit
 cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
 cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
-cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
-                                        = CmmLabelDiffOff l1 l2 (m+byte_off)
+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
 cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
 cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
 
@@ -340,7 +341,6 @@ cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]
 cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
 cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
 cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
---cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
 cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
 cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
 cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
@@ -385,6 +385,14 @@ hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
 hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
 hasNoGlobalRegs _ = False
 
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _          = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _                  = False
+
 ---------------------------------------------------
 --
 --      Tagging
@@ -392,23 +400,20 @@ hasNoGlobalRegs _ = False
 ---------------------------------------------------
 
 -- Tag bits mask
---cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
 cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
 cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
 cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
 
 -- Used to untag a possibly tagged pointer
 -- A static label need not be untagged
-cmmUntag :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
 cmmUntag _ e@(CmmLit (CmmLabel _)) = e
 -- Default case
 cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
 
 -- Test if a closure pointer is untagged
-cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
 cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
 
-cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
 -- Get constructor tag, but one based.
 cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
 
@@ -451,20 +456,17 @@ regUsedIn dflags = regUsedIn_ where
 --
 ---------------------------------------------
 
-mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
+mkLiveness :: DynFlags -> [LocalReg] -> Liveness
 mkLiveness _      [] = []
 mkLiveness dflags (reg:regs)
-  = take sizeW bits ++ mkLiveness dflags regs
+  = bits ++ mkLiveness dflags regs
   where
-    sizeW = case reg of
-              Nothing -> 1
-              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
-                        `quot` wORD_SIZE dflags
-                        -- number of words, rounded up
-    bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
+            `quot` wORD_SIZE dflags
+            -- number of words, rounded up
+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
 
-    is_non_ptr Nothing    = True
-    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
+    is_non_ptr = not $ isGcPtrType (localRegType reg)
 
 
 -- ============================================== -
@@ -486,12 +488,6 @@ toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
 ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
 ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
 
-insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
-insertBlock block map =
-  ASSERT(isNothing $ mapLookup id map)
-  mapInsert id block map
-  where id = entryLabel block
-
 toBlockList :: CmmGraph -> [CmmBlock]
 toBlockList g = mapElems $ toBlockMap g
 
@@ -554,11 +550,12 @@ mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGra
 mapGraphNodes1 f = modifyGraph (mapGraph f)
 
 
-foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
-foldGraphBlocks k z g = mapFold k z $ toBlockMap g
+foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
 
-postorderDfs :: CmmGraph -> [CmmBlock]
-postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+    revPostorderFrom (toBlockMap g) (g_entry g)
 
 -------------------------------------------------
 -- Tick utilities
@@ -569,3 +566,18 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
   where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
         goStmt  (CmmTick t) ts = t:ts
         goStmt  _other      ts = ts
+
+
+-- -----------------------------------------------------------------------------
+-- Access to common global registers
+
+baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
+baseExpr = CmmReg baseReg
+spExpr = CmmReg spReg
+spLimExpr = CmmReg spLimReg
+hpExpr = CmmReg hpReg
+hpLimExpr = CmmReg hpLimReg
+currentTSOExpr = CmmReg currentTSOReg
+currentNurseryExpr = CmmReg currentNurseryReg
+cccsExpr = CmmReg cccsReg
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
index 33595d8987..da37495530 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -22,6 +22,8 @@ module Debug (
   UnwindExpr(..), toUnwindExpr
   ) where
 
+import GhcPrelude
+
 import BlockId
 import CLabel
 import Cmm
@@ -33,7 +35,7 @@ import Outputable
 import PprCore         ()
 import PprCmmExpr      ( pprExpr )
 import SrcLoc
-import Util
+import Util            ( seqList )
 
 import Hoopl.Block
 import Hoopl.Collections
@@ -44,6 +46,7 @@ import Data.Maybe
 import Data.List     ( minimumBy, nubBy )
 import Data.Ord      ( comparing )
 import qualified Data.Map as Map
+import Data.Either   ( partitionEithers )
 
 -- | Debug information about a block of code. Ticks scope over nested
 -- blocks.
@@ -98,7 +101,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
       -- Analyse tick scope structure: Each one is either a top-level
       -- tick scope, or the child of another.
       (topScopes, childScopes)
-        = splitEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
+        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
       findP tsc GlobalScope = Left tsc -- top scope
       findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
                     | otherwise                   = findP tsc scp'
@@ -328,7 +331,7 @@ code,
            v :: P64 = R2;
            if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
 
-After c2fe we we may pass to either c2ff or c2fg; let's first consider the
+After c2fe we may pass to either c2ff or c2fg; let's first consider the
 former. In this case there is nothing in particular that we need to do other
 than reiterate what we already know about Sp,
 
@@ -346,8 +349,8 @@ in addition to the usual beginning-of-block statement,
            unwind Sp = Just Sp + 0;
            I64[Sp - 8] = c2dD;
            R1 = v :: P64;
-           unwind Sp = Just Sp + 8;
            Sp = Sp - 8;
+           unwind Sp = Just Sp + 8;
            if (R1 & 7 != 0) goto c2dD; else goto c2dE;
 
 The remaining blocks are simple,
@@ -389,10 +392,95 @@ The flow of unwinding information through the compiler is a bit convoluted:
 
  * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
 
- * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables
+ * These DebugBlocks are then converted to, e.g., DWARF unwinding tables
    (by the Dwarf module) and emitted in the final object.
 
-See also: Note [Unwinding information in the NCG] in AsmCodeGen.
+See also:
+  Note [Unwinding information in the NCG] in AsmCodeGen,
+  Note [Unwind pseudo-instruction in Cmm],
+  Note [Debugging DWARF unwinding info].
+
+
+Note [Debugging DWARF unwinding info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For debugging generated unwinding info I've found it most useful to dump the
+disassembled binary with objdump -D and dump the debug info with
+readelf --debug-dump=frames-interp.
+
+You should get something like this:
+
+  0000000000000010 <stg_catch_frame_info>:
+    10:   48 83 c5 18             add    $0x18,%rbp
+    14:   ff 65 00                jmpq   *0x0(%rbp)
+
+and:
+
+  Contents of the .debug_frame section:
+
+  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16
+     LOC           CFA      rbp   rsp   ra
+  0000000000000000 rbp+0    v+0   s     c+0
+
+  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017
+     LOC           CFA      rbp   rsp   ra
+  000000000000000f rbp+0    v+0   s     c+0
+  000000000000000f rbp+24   v+0   s     c+0
+
+To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in
+Appendix 5 (page 101 of the pdf) and more details in the relevant section.
+
+The key thing to keep in mind is that the value at LOC is the value from
+*before* the instruction at LOC executes. In other words it answers the
+question: if my $rip is at LOC, how do I get the relevant values given the
+values obtained through unwinding so far.
+
+If the readelf --debug-dump=frames-interp output looks wrong, it may also be
+useful to look at readelf --debug-dump=frames, which is closer to the
+information that GHC generated.
+
+It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm
+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]
+explains how to interpret it.
+
+Inside gdb there are a couple useful commands for inspecting frames.
+For example:
+
+  gdb> info frame <num>
+
+It shows the values of registers obtained through unwinding.
+
+Another useful thing to try when debugging the DWARF unwinding is to enable
+extra debugging output in GDB:
+
+  gdb> set debug frame 1
+
+This makes GDB produce a trace of its internal workings. Having gone this far,
+it's just a tiny step to run GDB in GDB. Make sure you install debugging
+symbols for gdb if you obtain it through a package manager.
+
+Keep in mind that the current release of GDB has an instruction pointer handling
+heuristic that works well for C-like languages, but doesn't always work for
+Haskell. See Note [Info Offset] in Dwarf.Types for more details.
+
+Note [Unwind pseudo-instruction in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't
+generate any assembly, but controls what DWARF unwinding information gets
+generated.
+
+It's important to understand what ranges of code the unwind pseudo-instruction
+refers to.
+For a sequence of CmmNodes like:
+
+  A // starts at addr X and ends at addr Y-1
+  unwind Sp = Just Sp + 16;
+  B // starts at addr Y and ends at addr Z
+
+the unwind statement reflects the state after A has executed, but before B
+has executed. If you consult the Note [Debugging DWARF unwinding info], the
+LOC this information will end up in is Y.
 -}
 
 -- | A label associated with an 'UnwindTable'
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
index 3623fcd242..c4ff1794e8 100644
--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -33,6 +33,7 @@ module Hoopl.Block
     , replaceLastNode
     ) where
 
+import GhcPrelude
 
 -- -----------------------------------------------------------------------------
 -- Shapes: Open and Closed
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
index 679057626b..f8bdfda3d1 100644
--- a/compiler/cmm/Hoopl/Collections.hs
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -1,11 +1,22 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Hoopl.Collections
     ( IsSet(..)
     , setInsertList, setDeleteList, setUnions
     , IsMap(..)
     , mapInsertList, mapDeleteList, mapUnions
+    , UniqueMap, UniqueSet
     ) where
 
+import GhcPrelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
 import Data.List (foldl', foldl1')
 
 class IsSet set where
@@ -25,7 +36,8 @@ class IsSet set where
   setIntersection :: set -> set -> set
   setIsSubsetOf :: set -> set -> Bool
 
-  setFold :: (ElemOf set -> b -> b) -> b -> set -> b
+  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
 
   setElems :: set -> [ElemOf set]
   setFromList :: [ElemOf set] -> set
@@ -56,6 +68,7 @@ class IsMap map where
   mapInsert :: KeyOf map -> a -> map a -> map a
   mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
   mapDelete :: KeyOf map -> map a -> map a
+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
 
   mapUnion :: map a -> map a -> map a
   mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
@@ -65,8 +78,9 @@ class IsMap map where
 
   mapMap :: (a -> b) -> map a -> map b
   mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
-  mapFold :: (a -> b -> b) -> b -> map a -> b
-  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b
+  mapFoldl :: (b -> a -> b) -> b -> map a -> b
+  mapFoldr :: (a -> b -> b) -> b -> map a -> b
+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
   mapFilter :: (a -> Bool) -> map a -> map a
 
   mapElems :: map a -> [a]
@@ -85,3 +99,70 @@ mapDeleteList keys map = foldl' (flip mapDelete) map keys
 mapUnions :: IsMap map => [map a] -> map a
 mapUnions [] = mapEmpty
 mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Int
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+
+  setFoldl k z (US s) = S.foldl' k z s
+  setFoldr k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Int
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+  mapAlter f k (UM m) = UM (M.alter f k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+  mapFoldl k z (UM m) = M.foldl' k z m
+  mapFoldr k z (UM m) = M.foldr k z m
+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFilter f (UM m) = UM (M.filter f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index c2ace502b3..bf12b3f6a1 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -30,14 +30,16 @@ module Hoopl.Dataflow
   , rewriteCmmBwd
   , changedIf
   , joinOutFacts
+  , joinFacts
   )
 where
 
+import GhcPrelude
+
 import Cmm
 import UniqSupply
 
 import Data.Array
-import Data.List
 import Data.Maybe
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IntSet
@@ -109,8 +111,7 @@ analyzeCmm dir lattice transfer cmmGraph initFact =
         blockMap =
             case hooplGraph of
                 GMany NothingO bm NothingO -> bm
-        entries = if mapNull initFact then [entry] else mapKeys initFact
-    in fixpointAnalysis dir lattice transfer entries blockMap initFact
+    in fixpointAnalysis dir lattice transfer entry blockMap initFact
 
 -- Fixpoint algorithm.
 fixpointAnalysis
@@ -118,19 +119,20 @@ fixpointAnalysis
        Direction
     -> DataflowLattice f
     -> TransferFun f
-    -> [Label]
+    -> Label
     -> LabelMap CmmBlock
     -> FactBase f
     -> FactBase f
-fixpointAnalysis direction lattice do_block entries blockmap = loop start
+fixpointAnalysis direction lattice do_block entry blockmap = loop start
   where
     -- Sorting the blocks helps to minimize the number of times we need to
     -- process blocks. For instance, for forward analysis we want to look at
     -- blocks in reverse postorder. Also, see comments for sortBlocks.
-    blocks     = sortBlocks direction entries blockmap
+    blocks     = sortBlocks direction entry blockmap
     num_blocks = length blocks
     block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start" #-} [0 .. num_blocks - 1]
+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
+      [0 .. num_blocks - 1]
     dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
     join       = fact_join lattice
 
@@ -138,17 +140,17 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
         :: IntHeap     -- ^ Worklist, i.e., blocks to process
         -> FactBase f  -- ^ Current result (increases monotonically)
         -> FactBase f
-    loop []              !fbase1 = fbase1
-    loop (index : todo1) !fbase1 =
+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
         let block = block_arr ! index
             out_facts = {-# SCC "do_block" #-} do_block block fbase1
             -- For each of the outgoing edges, we join it with the current
             -- information in fbase1 and (if something changed) we update it
             -- and add the affected blocks to the worklist.
             (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
-                mapFoldWithKey
+                mapFoldlWithKey
                     (updateFact join dep_blocks) (todo1, fbase1) out_facts
         in loop todo2 fbase2
+    loop _ !fbase1 = fbase1
 
 rewriteCmmBwd
     :: DataflowLattice f
@@ -171,9 +173,8 @@ rewriteCmm dir lattice rwFun cmmGraph initFact = do
         blockMap1 =
             case hooplGraph of
                 GMany NothingO bm NothingO -> bm
-        entries = if mapNull initFact then [entry] else mapKeys initFact
     (blockMap2, facts) <-
-        fixpointRewrite dir lattice rwFun entries blockMap1 initFact
+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact
     return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
 
 fixpointRewrite
@@ -181,20 +182,21 @@ fixpointRewrite
        Direction
     -> DataflowLattice f
     -> RewriteFun f
-    -> [Label]
+    -> Label
     -> LabelMap CmmBlock
     -> FactBase f
     -> UniqSM (LabelMap CmmBlock, FactBase f)
-fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
   where
     -- Sorting the blocks helps to minimize the number of times we need to
     -- process blocks. For instance, for forward analysis we want to look at
     -- blocks in reverse postorder. Also, see comments for sortBlocks.
-    blocks     = sortBlocks dir entries blockmap
+    blocks     = sortBlocks dir entry blockmap
     num_blocks = length blocks
     block_arr  = {-# SCC "block_arr_rewrite" #-}
                  listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start_rewrite" #-} [0 .. num_blocks - 1]
+    start      = {-# SCC "start_rewrite" #-}
+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
     dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
     join       = fact_join lattice
 
@@ -203,8 +205,8 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
         -> LabelMap CmmBlock  -- ^ Rewritten blocks.
         -> FactBase f         -- ^ Current facts.
         -> UniqSM (LabelMap CmmBlock, FactBase f)
-    loop []              !blocks1 !fbase1 = return (blocks1, fbase1)
-    loop (index : todo1) !blocks1 !fbase1 = do
+    loop todo !blocks1 !fbase1
+      | Just (index, todo1) <- IntSet.minView todo = do
         -- Note that we use the *original* block here. This is important.
         -- We're optimistically rewriting blocks even before reaching the fixed
         -- point, which means that the rewrite might be incorrect. So if the
@@ -215,9 +217,10 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
             do_block block fbase1
         let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
             (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
-                mapFoldWithKey
+                mapFoldlWithKey
                     (updateFact join dep_blocks) (todo1, fbase1) out_facts
         loop todo2 blocks2 fbase2
+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
 
 
 {-
@@ -263,20 +266,15 @@ we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
 -- | Sort the blocks into the right order for analysis. This means reverse
 -- postorder for a forward analysis. For the backward one, we simply reverse
 -- that (see Note [Backward vs forward analysis]).
---
--- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS
--- it returns the *reverse* postorder of the blocks (it visits blocks in the
--- postorder and uses (:) to collect them, which gives the reverse of the
--- visitation order).
 sortBlocks
     :: NonLocal n
-    => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C]
-sortBlocks direction entries blockmap =
+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
+sortBlocks direction entry blockmap =
     case direction of
         Fwd -> fwd
         Bwd -> reverse fwd
   where
-    fwd = postorder_dfs_from blockmap entries
+    fwd = revPostorderFrom blockmap entry
 
 -- Note [Backward vs forward analysis]
 --
@@ -328,11 +326,11 @@ mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
 updateFact
     :: JoinFun f
     -> LabelMap IntSet
+    -> (IntHeap, FactBase f)
     -> Label
     -> f -- out fact
     -> (IntHeap, FactBase f)
-    -> (IntHeap, FactBase f)
-updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
   = case lookupFact lbl fbase of
       Nothing ->
           -- Note [No old fact]
@@ -342,7 +340,7 @@ updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
               (NotChanged _) -> (todo, fbase)
               (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
   where
-    changed = IntSet.foldr insertIntHeap todo $
+    changed = todo `IntSet.union`
               mapFindWithDefault IntSet.empty lbl dep_blocks
 
 {-
@@ -376,6 +374,11 @@ joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
         , isJust fact
         ]
 
+joinFacts :: DataflowLattice f -> [f] -> f
+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+
 -- | Returns the joined facts for each label.
 mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
 mkFactBase lattice = foldl' add mapEmpty
@@ -434,19 +437,4 @@ joinBlocksOO (BMiddle n) b = blockCons n b
 joinBlocksOO b (BMiddle n) = blockSnoc b n
 joinBlocksOO b1 b2 = BCat b1 b2
 
--- -----------------------------------------------------------------------------
--- a Heap of Int
-
--- We should really use a proper Heap here, but my attempts to make
--- one have not succeeded in beating the simple ordered list.  Another
--- alternative is IntSet (using deleteFindMin), but that was also
--- slower than the ordered list in my experiments --SDM 25/1/2012
-
-type IntHeap = [Int] -- ordered
-
-insertIntHeap :: Int -> [Int] -> [Int]
-insertIntHeap x [] = [x]
-insertIntHeap x (y:ys)
-  | x < y     = x : y : ys
-  | x == y    = x : ys
-  | otherwise = y : insertIntHeap x ys
+type IntHeap = IntSet
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
index 87da072458..0142f70c76 100644
--- a/compiler/cmm/Hoopl/Graph.hs
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
@@ -14,10 +15,13 @@ module Hoopl.Graph
     , labelsDefined
     , mapGraph
     , mapGraphBlocks
-    , postorder_dfs_from
+    , revPostorderFrom
     ) where
 
 
+import GhcPrelude
+import Util
+
 import Hoopl.Label
 import Hoopl.Block
 import Hoopl.Collections
@@ -49,13 +53,14 @@ emptyBody = mapEmpty
 bodyList :: Body' block n -> [(Label,block n C C)]
 bodyList body = mapToList body
 
-addBlock :: NonLocal thing
-         => thing C C -> LabelMap (thing C C)
-         -> LabelMap (thing C C)
-addBlock b body
-  | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
-  | otherwise          = mapInsert lbl b body
-  where lbl = entryLabel b
+addBlock
+    :: (NonLocal block, HasDebugCallStack)
+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+  where
+    lbl = entryLabel block
+    add Nothing = Just block
+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
 
 
 -- ---------------------------------------------------------------------------
@@ -107,9 +112,9 @@ labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
               -> LabelSet
 labelsDefined GNil      = setEmpty
 labelsDefined (GUnit{}) = setEmpty
-labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
-  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
-        addEntry label _ labels = setInsert label labels
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+        addEntry labels label _ = setInsert label labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
         exitLabel NothingO  = setEmpty
         exitLabel (JustO b) = setSingleton (entryLabel b)
@@ -117,22 +122,10 @@ labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
 
 ----------------------------------------------------------------
 
-class LabelsPtr l where
-  targetLabels :: l -> [Label]
-
-instance NonLocal n => LabelsPtr (n e C) where
-  targetLabels n = successors n
-
-instance LabelsPtr Label where
-  targetLabels l = [l]
-
-instance LabelsPtr LabelSet where
-  targetLabels = setElems
-
-instance LabelsPtr l => LabelsPtr [l] where
-  targetLabels = concatMap targetLabels
-
--- | This is the most important traversal over this data structure.  It drops
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure.  It drops
 -- unreachable code and puts blocks in an order that is good for solving forward
 -- dataflow problems quickly.  The reverse order is good for solving backward
 -- dataflow problems quickly.  The forward order is also reasonably good for
@@ -141,59 +134,52 @@ instance LabelsPtr l => LabelsPtr [l] where
 -- that you would need a more serious analysis, probably based on dominators, to
 -- identify loop headers.
 --
--- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
--- representation, when for most purposes the plain 'Graph' representation is
--- more mathematically elegant (but results in more complicated code).
---
--- Here's an easy way to go wrong!  Consider
+-- For forward analyses we want reverse postorder visitation, consider:
 -- @
 --      A -> [B,C]
 --      B -> D
 --      C -> D
 -- @
--- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
--- Better to get [A,B,C,D]
-
-
--- | Traversal: 'postorder_dfs' returns a list of blocks reachable
--- from the entry of enterable graph. The entry and exit are *not* included.
--- The list has the following property:
---
---      Say a "back reference" exists if one of a block's
---      control-flow successors precedes it in the output list
---
---      Then there are as few back references as possible
---
--- The output is suitable for use in
--- a forward dataflow problem.  For a backward problem, simply reverse
--- the list.  ('postorder_dfs' is sufficiently tricky to implement that
--- one doesn't want to try and maintain both forward and backward
--- versions.)
-
-postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
-                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]
-postorder_dfs_from_except blocks b visited =
- vchildren (get_children b) (\acc _visited -> acc) [] visited
- where
-   vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
-   vnode block cont acc visited =
-        if setMember id visited then
-            cont acc visited
-        else
-            let cont' acc visited = cont (block:acc) visited in
-            vchildren (get_children block) cont' acc (setInsert id visited)
-      where id = entryLabel block
-   vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
-   vchildren bs cont acc visited = next bs acc visited
-      where next children acc visited =
-                case children of []     -> cont acc visited
-                                 (b:bs) -> vnode b (next bs) acc visited
-   get_children :: forall l. LabelsPtr l => l -> [block C C]
-   get_children block = foldr add_id [] $ targetLabels block
-   add_id id rst = case lookupFact id blocks of
-                      Just b -> b : rst
-                      Nothing -> rst
-
-postorder_dfs_from
-    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+  :: forall block.  (NonLocal block)
+  => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+  where
+    start_worklist = lookup_for_descend start Nil
+
+    -- To compute the postorder we need to "visit" a block (mark as done)
+    -- *after* visiting all its successors. So we need to know whether we
+    -- already processed all successors of each block (and @NonLocal@ allows
+    -- arbitrary many successors). So we use an explicit stack with an extra bit
+    -- of information:
+    -- * @ConsTodo@ means to explore the block if it wasn't visited before
+    -- * @ConsMark@ means that all successors were already done and we can add
+    --   the block to the result.
+    --
+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+    -- them (i.e., we use @(:)@), which means that the final list is in reverse
+    -- postorder.
+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+    go Nil                      !_           !result = result
+    go (ConsMark block rest)    !wip_or_done !result =
+        go rest wip_or_done (block : result)
+    go (ConsTodo block rest)    !wip_or_done !result
+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+        | otherwise =
+            let new_worklist =
+                    foldr lookup_for_descend
+                          (ConsMark block rest)
+                          (successors block)
+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+    lookup_for_descend label wl
+      | Just b <- mapLookup label graph = ConsTodo b wl
+      | otherwise =
+           error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
index 5ee4f72fc3..7fddbf4c3f 100644
--- a/compiler/cmm/Hoopl/Label.hs
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -2,32 +2,37 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Hoopl.Label
     ( Label
     , LabelMap
     , LabelSet
     , FactBase
     , lookupFact
-    , uniqueToLbl
+    , mkHooplLabel
     ) where
 
+import GhcPrelude
+
 import Outputable
 
-import Hoopl.Collections
 -- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
-import Hoopl.Unique
+import Hoopl.Collections
 
 import Unique (Uniquable(..))
+import TrieMap
+
 
 -----------------------------------------------------------------------------
 --              Label
 -----------------------------------------------------------------------------
 
-newtype Label = Label { lblToUnique :: Unique }
+newtype Label = Label { lblToUnique :: Int }
   deriving (Eq, Ord)
 
-uniqueToLbl :: Unique -> Label
-uniqueToLbl = Label
+mkHooplLabel :: Int -> Label
+mkHooplLabel = Label
 
 instance Show Label where
   show (Label n) = "L" ++ show n
@@ -60,9 +65,10 @@ instance IsSet LabelSet where
   setIntersection (LS x) (LS y) = LS (setIntersection x y)
   setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
 
-  setFold k z (LS s) = setFold (k . uniqueToLbl) z s
+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
 
-  setElems (LS s) = map uniqueToLbl (setElems s)
+  setElems (LS s) = map mkHooplLabel (setElems s)
   setFromList ks = LS (setFromList (map lblToUnique ks))
 
 -----------------------------------------------------------------------------
@@ -85,22 +91,25 @@ instance IsMap LabelMap where
   mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
   mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
   mapDelete (Label k) (LM m) = LM (mapDelete k m)
+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
 
   mapUnion (LM x) (LM y) = LM (mapUnion x y)
-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
   mapDifference (LM x) (LM y) = LM (mapDifference x y)
   mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
   mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
 
   mapMap f (LM m) = LM (mapMap f m)
-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
-  mapFold k z (LM m) = mapFold k z m
-  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
+  mapFoldl k z (LM m) = mapFoldl k z m
+  mapFoldr k z (LM m) = mapFoldr k z m
+  mapFoldlWithKey k z (LM m) =
+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
   mapFilter f (LM m) = LM (mapFilter f m)
 
   mapElems (LM m) = mapElems m
-  mapKeys (LM m) = map uniqueToLbl (mapKeys m)
-  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
   mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
   mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
 
@@ -113,6 +122,14 @@ instance Outputable LabelSet where
 instance Outputable a => Outputable (LabelMap a) where
   ppr = ppr . mapToList
 
+instance TrieMap LabelMap where
+  type Key LabelMap = Label
+  emptyTM = mapEmpty
+  lookupTM k m = mapLookup k m
+  alterTM k f m = mapAlter f k m
+  foldTM k m z = mapFoldr k z m
+  mapTM f m = mapMap f m
+
 -----------------------------------------------------------------------------
 -- FactBase
 
diff --git a/compiler/cmm/Hoopl/Unique.hs b/compiler/cmm/Hoopl/Unique.hs
deleted file mode 100644
index f27961bb28..0000000000
--- a/compiler/cmm/Hoopl/Unique.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hoopl.Unique
-    ( Unique
-    , UniqueMap
-    , UniqueSet
-    , intToUnique
-    ) where
-
-import qualified Data.IntMap as M
-import qualified Data.IntSet as S
-
-import Hoopl.Collections
-
-
------------------------------------------------------------------------------
---              Unique
------------------------------------------------------------------------------
-
-type Unique = Int
-
-intToUnique :: Int -> Unique
-intToUnique = id
-
------------------------------------------------------------------------------
--- UniqueSet
-
-newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
-
-instance IsSet UniqueSet where
-  type ElemOf UniqueSet = Unique
-
-  setNull (US s) = S.null s
-  setSize (US s) = S.size s
-  setMember k (US s) = S.member k s
-
-  setEmpty = US S.empty
-  setSingleton k = US (S.singleton k)
-  setInsert k (US s) = US (S.insert k s)
-  setDelete k (US s) = US (S.delete k s)
-
-  setUnion (US x) (US y) = US (S.union x y)
-  setDifference (US x) (US y) = US (S.difference x y)
-  setIntersection (US x) (US y) = US (S.intersection x y)
-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
-
-  setFold k z (US s) = S.foldr k z s
-
-  setElems (US s) = S.elems s
-  setFromList ks = US (S.fromList ks)
-
------------------------------------------------------------------------------
--- UniqueMap
-
-newtype UniqueMap v = UM (M.IntMap v)
-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-instance IsMap UniqueMap where
-  type KeyOf UniqueMap = Unique
-
-  mapNull (UM m) = M.null m
-  mapSize (UM m) = M.size m
-  mapMember k (UM m) = M.member k m
-  mapLookup k (UM m) = M.lookup k m
-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
-
-  mapEmpty = UM M.empty
-  mapSingleton k v = UM (M.singleton k v)
-  mapInsert k v (UM m) = UM (M.insert k v m)
-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
-  mapDelete k (UM m) = UM (M.delete k m)
-
-  mapUnion (UM x) (UM y) = UM (M.union x y)
-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)
-  mapDifference (UM x) (UM y) = UM (M.difference x y)
-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
-
-  mapMap f (UM m) = UM (M.map f m)
-  mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)
-  mapFold k z (UM m) = M.foldr k z m
-  mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m
-  mapFilter f (UM m) = UM (M.filter f m)
-
-  mapElems (UM m) = M.elems m
-  mapKeys (UM m) = M.keys m
-  mapToList (UM m) = M.toList m
-  mapFromList assocs = UM (M.fromList assocs)
-  mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 62dfd34da3..70229d067d 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, GADTs #-}
+{-# LANGUAGE BangPatterns, GADTs #-}
 
 module MkGraph
   ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
@@ -21,6 +21,8 @@ module MkGraph
   )
 where
 
+import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
+
 import BlockId
 import Cmm
 import CmmCallConv
@@ -35,13 +37,7 @@ import ForeignCall
 import OrdList
 import SMRep (ByteOff)
 import UniqSupply
-
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
-
-#include "HsVersions.h"
+import Util
 
 
 -----------------------------------------------------------------------------
@@ -185,12 +181,10 @@ mkNop        :: CmmAGraph
 mkNop         = nilOL
 
 mkComment    :: FastString -> CmmAGraph
-#if defined(DEBUG)
--- SDM: generating all those comments takes time, this saved about 4% for me
-mkComment fs  = mkMiddle $ CmmComment fs
-#else
-mkComment _   = nilOL
-#endif
+mkComment fs
+  -- SDM: generating all those comments takes time, this saved about 4% for me
+  | debugIsOn = mkMiddle $ CmmComment fs
+  | otherwise = nilOL
 
 ---------- Assignment and store
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 7d36c120b0..a979d49501 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -26,6 +26,8 @@ module PprC (
 #include "HsVersions.h"
 
 -- Cmm stuff
+import GhcPrelude
+
 import BlockId
 import CLabel
 import ForeignCall
@@ -377,14 +379,10 @@ pprExpr e = case e of
     CmmReg reg      -> pprCastReg reg
     CmmRegOff reg 0 -> pprCastReg reg
 
-    CmmRegOff reg i
-        | i < 0 && negate_ok -> pprRegOff (char '-') (-i)
-        | otherwise          -> pprRegOff (char '+') i
-      where
-        pprRegOff op i' = pprCastReg reg <> op <> int i'
-        negate_ok = negate (fromIntegral i :: Integer) <
-                    fromIntegral (maxBound::Int)
-                     -- overflow is undefined; see #7620
+    -- CmmRegOff is an alias of MO_Add
+    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->
+                       pprCastReg reg <> char '+' <>
+                       pprHexVal (fromIntegral i) (wordWidth dflags)
 
     CmmMachOp mop args -> pprMachOpApp mop args
 
@@ -493,7 +491,7 @@ pprLit lit = case lit of
     CmmHighStackMark   -> panic "PprC printing high stack mark"
     CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
     CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
-    CmmLabelDiffOff clbl1 _ i
+    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C
         -- WARNING:
         --  * the lit must occur in the info table clbl2
         --  * clbl1 must be an SRT, a slow entry point or a large bitmap
@@ -504,7 +502,7 @@ pprLit lit = case lit of
 
 pprLit1 :: CmmLit -> SDoc
 pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
-pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)
 pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
 pprLit1 other = pprLit other
 
@@ -536,13 +534,29 @@ pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
                             CmmStaticLit (CmmInt q W32) : rest)
   where r = i .&. 0xffffffff
         q = i `shiftR` 32
+pprStatics dflags (CmmStaticLit (CmmInt a W32) :
+                   CmmStaticLit (CmmInt b W32) : rest)
+  | wordWidth dflags == W64
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :
+                            rest)
+pprStatics dflags (CmmStaticLit (CmmInt a W16) :
+                   CmmStaticLit (CmmInt b W16) : rest)
+  | wordWidth dflags == W32
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :
+                            rest)
 pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
   | w /= wordWidth dflags
-  = panic "pprStatics: cannot emit a non-word-sized static literal"
+  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
 pprStatics dflags (CmmStaticLit lit : rest)
   = pprLit1 lit : pprStatics dflags rest
 pprStatics _ (other : _)
-  = pprPanic "pprWord" (pprStatic other)
+  = pprPanic "pprStatics: other" (pprStatic other)
 
 pprStatic :: CmmStatic -> SDoc
 pprStatic s = case s of
@@ -721,6 +735,8 @@ pprMachOp_for_C mop = case mop of
                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
                                       ++ " should have been handled earlier!")
 
+        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"
+
 signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
 signedOp (MO_S_Quot _)    = True
 signedOp (MO_S_Rem  _)    = True
@@ -759,6 +775,9 @@ pprCallishMachOp_for_C mop
         MO_F64_Tanh     -> text "tanh"
         MO_F64_Asin     -> text "asin"
         MO_F64_Acos     -> text "acos"
+        MO_F64_Atanh    -> text "atanh"
+        MO_F64_Asinh    -> text "asinh"
+        MO_F64_Acosh    -> text "acosh"
         MO_F64_Atan     -> text "atan"
         MO_F64_Log      -> text "log"
         MO_F64_Exp      -> text "exp"
@@ -774,6 +793,9 @@ pprCallishMachOp_for_C mop
         MO_F32_Asin     -> text "asinf"
         MO_F32_Acos     -> text "acosf"
         MO_F32_Atan     -> text "atanf"
+        MO_F32_Asinh    -> text "asinhf"
+        MO_F32_Acosh    -> text "acoshf"
+        MO_F32_Atanh    -> text "atanhf"
         MO_F32_Log      -> text "logf"
         MO_F32_Exp      -> text "expf"
         MO_F32_Sqrt     -> text "sqrtf"
@@ -782,8 +804,11 @@ pprCallishMachOp_for_C mop
         MO_Memcpy _     -> text "memcpy"
         MO_Memset _     -> text "memset"
         MO_Memmove _    -> text "memmove"
+        MO_Memcmp _     -> text "memcmp"
         (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
         (MO_Clz w)      -> ptext (sLit $ clzLabel w)
         (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
         (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
@@ -796,6 +821,7 @@ pprCallishMachOp_for_C mop
         MO_U_QuotRem  {} -> unsupported
         MO_U_QuotRem2 {} -> unsupported
         MO_Add2       {} -> unsupported
+        MO_AddWordC   {} -> unsupported
         MO_SubWordC   {} -> unsupported
         MO_AddIntC    {} -> unsupported
         MO_SubIntC    {} -> unsupported
@@ -1075,7 +1101,7 @@ te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
 te_Lit :: CmmLit -> TE ()
 te_Lit (CmmLabel l) = te_lbl l
 te_Lit (CmmLabelOff l _) = te_lbl l
-te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
+te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1
 te_Lit _ = return ()
 
 te_Stmt :: CmmNode e x -> TE ()
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index dbd4619416..90f26e4247 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -15,8 +15,8 @@
 --
 -- As such, this should be a well-defined syntax: we want it to look nice.
 -- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
 -- than C--'s bits8 .. bits64.
 --
 -- We try to ensure that all information available in the abstract
@@ -39,6 +39,8 @@ module PprCmm
   )
 where
 
+import GhcPrelude hiding (succ)
+
 import BlockId ()
 import CLabel
 import Cmm
@@ -55,8 +57,6 @@ import PprCore ()
 import BasicTypes
 import Hoopl.Block
 import Hoopl.Graph
-import Data.List
-import Prelude hiding (succ)
 
 -------------------------------------------------
 -- Outputable instances
@@ -108,7 +108,7 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
 
 pprTopInfo :: CmmTopInfo -> SDoc
 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
-  vcat [text "info_tbl: " <> ppr info_tbl,
+  vcat [text "info_tbls: " <> ppr info_tbl,
         text "stack_info: " <> ppr stack_info]
 
 ----------------------------------------------------------
@@ -141,8 +141,8 @@ pprCmmGraph g
    = text "{" <> text "offset"
   $$ nest 2 (vcat $ map ppr blocks)
   $$ text "}"
-  where blocks = postorderDfs g
-    -- postorderDfs has the side-effect of discarding unreachable code,
+  where blocks = revPostorder g
+    -- revPostorder has the side-effect of discarding unreachable code,
     -- so pretty-printed Cmm will omit any unreachable blocks.  This can
     -- sometimes be confusing.
 
@@ -185,9 +185,13 @@ pprNode node = pp_node <+> pp_debug
     pp_node :: SDoc
     pp_node = sdocWithDynFlags $ \dflags -> case node of
       -- label:
-      CmmEntry id tscope -> ppr id <> colon <+>
+      CmmEntry id tscope -> lbl <> colon <+>
          (sdocWithDynFlags $ \dflags ->
            ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
+          where
+            lbl = if gopt Opt_SuppressUniques dflags
+                then text "_lbl_"
+                else ppr id
 
       -- // text
       CmmComment s -> text "//" <+> ftext s
@@ -252,8 +256,8 @@ pprNode node = pp_node <+> pp_debug
                             , ppr l <> semi
                             ]
             def | Just l <- mbdef = hsep
-                            [ text "default: goto"
-                            , ppr l <> semi
+                            [ text "default:"
+                            , braces (text "goto" <+> ppr l <> semi)
                             ]
                 | otherwise = empty
 
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index ce8fb0dc5d..c4ee6fd068 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 ----------------------------------------------------------------------------
 --
 -- Pretty-printing of common Cmm types
@@ -15,8 +13,8 @@
 --
 -- As such, this should be a well-defined syntax: we want it to look nice.
 -- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
 -- than C--'s bits8 .. bits64.
 --
 -- We try to ensure that all information available in the abstract
@@ -40,6 +38,8 @@ module PprCmmDecl
     )
 where
 
+import GhcPrelude
+
 import PprCmmExpr
 import Cmm
 
@@ -52,7 +52,6 @@ import System.IO
 
 -- Temp Jan08
 import SMRep
-#include "../includes/rts/storage/FunTypes.h"
 
 
 pprCmms :: (Outputable info, Outputable g)
@@ -116,18 +115,15 @@ pprTop (CmmData section ds) =
 pprInfoTable :: CmmInfoTable -> SDoc
 pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
                            , cit_prof = prof_info
-                           , cit_srt = _srt })
-  = vcat [ text "label:" <+> ppr lbl
-         , text "rep:" <> ppr rep
+                           , cit_srt = srt })
+  = vcat [ text "label: " <> ppr lbl
+         , text "rep: " <> ppr rep
          , case prof_info of
              NoProfilingInfo -> empty
-             ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct
-                                         , text "desc: " <> pprWord8String cd ] ]
-
-instance Outputable C_SRT where
-  ppr NoC_SRT = text "_no_srt_"
-  ppr (C_SRT label off bitmap)
-      = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)
+             ProfilingInfo ct cd ->
+               vcat [ text "type: " <> pprWord8String ct
+                    , text "desc: " <> pprWord8String cd ]
+         , text "srt: " <> ppr srt ]
 
 instance Outputable ForeignHint where
   ppr NoHint     = empty
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 77c92407bc..7bf73f1ca6 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -13,8 +13,8 @@
 --
 -- As such, this should be a well-defined syntax: we want it to look nice.
 -- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
 -- than C--'s bits8 .. bits64.
 --
 -- We try to ensure that all information available in the abstract
@@ -38,9 +38,12 @@ module PprCmmExpr
     )
 where
 
+import GhcPrelude
+
 import CmmExpr
 
 import Outputable
+import DynFlags
 
 import Data.Maybe
 import Numeric ( fromRat )
@@ -196,7 +199,7 @@ pprLit lit = sdocWithDynFlags $ \dflags ->
     CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'
     CmmLabel clbl      -> ppr clbl
     CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
-    CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'
+    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
                                   <> ppr clbl2 <> ppr_offset i
     CmmBlock id        -> ppr id
     CmmHighStackMark -> text "<highSp>"
@@ -224,14 +227,18 @@ pprReg r
 -- We only print the type of the local reg if it isn't wordRep
 --
 pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep)
+pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->
 --   = ppr rep <> char '_' <> ppr uniq
 -- Temp Jan08
-   = char '_' <> ppr uniq <>
+    char '_' <> pprUnique dflags uniq <>
        (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
                     then dcolon <> ptr <> ppr rep
                     else dcolon <> ptr <> ppr rep)
    where
+     pprUnique dflags unique =
+        if gopt Opt_SuppressUniques dflags
+            then text "_locVar_"
+            else ppr unique
      ptr = empty
          --if isGcPtrType rep
          --      then doubleQuotes (text "ptr")
diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
index d40af4ff1c..743631527e 100644
--- a/compiler/cmm/SMRep.hs
+++ b/compiler/cmm/SMRep.hs
@@ -9,7 +9,7 @@ module SMRep (
         -- * Words and bytes
         WordOff, ByteOff,
         wordsToBytes, bytesToWordsRoundUp,
-        roundUpToWords,
+        roundUpToWords, roundUpTo,
 
         StgWord, fromStgWord, toStgWord,
         StgHalfWord, fromStgHalfWord, toStgHalfWord,
@@ -47,8 +47,7 @@ module SMRep (
         pprWord8String, stringToWord8s
     ) where
 
-#include "../HsVersions.h"
-#include "../includes/MachDeps.h"
+import GhcPrelude
 
 import BasicTypes( ConTagZ )
 import DynFlags
@@ -77,8 +76,11 @@ type ByteOff = Int
 -- | Round up the given byte count to the next byte count that's a
 -- multiple of the machine's word size.
 roundUpToWords :: DynFlags -> ByteOff -> ByteOff
-roundUpToWords dflags n =
-  (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1))
+roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)
+
+-- | Round up @base@ to a multiple of @size@.
+roundUpTo :: ByteOff -> ByteOff -> ByteOff
+roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))
 
 -- | Convert the given number of words to a number of bytes.
 --
@@ -277,10 +279,10 @@ isConRep (HeapRep _ _ _ Constr{}) = True
 isConRep _                        = False
 
 isThunkRep :: SMRep -> Bool
-isThunkRep (HeapRep _ _ _ Thunk{})         = True
+isThunkRep (HeapRep _ _ _ Thunk)           = True
 isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
-isThunkRep (HeapRep _ _ _ BlackHole{})     = True
-isThunkRep (HeapRep _ _ _ IndStatic{})     = True
+isThunkRep (HeapRep _ _ _ BlackHole)       = True
+isThunkRep (HeapRep _ _ _ IndStatic)       = True
 isThunkRep _                               = False
 
 isFunRep :: SMRep -> Bool
@@ -384,10 +386,10 @@ heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"
 
 closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
 closureTypeHdrSize dflags ty = case ty of
-                  Thunk{}         -> thunkHdrSize dflags
+                  Thunk           -> thunkHdrSize dflags
                   ThunkSelector{} -> thunkHdrSize dflags
-                  BlackHole{}     -> thunkHdrSize dflags
-                  IndStatic{}     -> thunkHdrSize dflags
+                  BlackHole       -> thunkHdrSize dflags
+                  IndStatic       -> thunkHdrSize dflags
                   _               -> fixedHdrSizeW dflags
         -- All thunks use thunkHdrSize, even if they are non-updatable.
         -- this is because we don't have separate closure types for
@@ -446,21 +448,19 @@ rtsClosureType rep
       HeapRep False 0 2 Fun{} -> FUN_0_2
       HeapRep False _ _ Fun{} -> FUN
 
-      HeapRep False 1 0 Thunk{} -> THUNK_1_0
-      HeapRep False 0 1 Thunk{} -> THUNK_0_1
-      HeapRep False 2 0 Thunk{} -> THUNK_2_0
-      HeapRep False 1 1 Thunk{} -> THUNK_1_1
-      HeapRep False 0 2 Thunk{} -> THUNK_0_2
-      HeapRep False _ _ Thunk{} -> THUNK
+      HeapRep False 1 0 Thunk -> THUNK_1_0
+      HeapRep False 0 1 Thunk -> THUNK_0_1
+      HeapRep False 2 0 Thunk -> THUNK_2_0
+      HeapRep False 1 1 Thunk -> THUNK_1_1
+      HeapRep False 0 2 Thunk -> THUNK_0_2
+      HeapRep False _ _ Thunk -> THUNK
 
       HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR
 
-      HeapRep True _ _ Fun{}    -> FUN_STATIC
-      HeapRep True _ _ Thunk{}  -> THUNK_STATIC
-
-      HeapRep False _ _ BlackHole{} -> BLACKHOLE
-
-      HeapRep False _ _ IndStatic{} -> IND_STATIC
+      HeapRep True _ _ Fun{}      -> FUN_STATIC
+      HeapRep True _ _ Thunk      -> THUNK_STATIC
+      HeapRep False _ _ BlackHole -> BLACKHOLE
+      HeapRep False _ _ IndStatic -> IND_STATIC
 
       _ -> panic "rtsClosureType"
 
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 7184153f10..6a2840294a 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE GADTs #-}
 
 -----------------------------------------------------------------------------
 --
@@ -10,7 +10,7 @@
 
 module CgUtils ( fixStgRegisters ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import CodeGen.Platform
 import Cmm
@@ -116,7 +116,7 @@ regTableOffset dflags n =
 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
 get_Regtable_addr_from_offset dflags _ offset =
     if haveRegBase (targetPlatform dflags)
-    then CmmRegOff (CmmGlobal BaseReg) offset
+    then CmmRegOff baseReg offset
     else regTableOffset dflags offset
 
 -- | Fixup global registers so that they assign to locations within the
diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs
index 80452d0585..3014a0596f 100644
--- a/compiler/codeGen/CodeGen/Platform.hs
+++ b/compiler/codeGen/CodeGen/Platform.hs
@@ -3,6 +3,8 @@ module CodeGen.Platform
        (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)
        where
 
+import GhcPrelude
+
 import CmmExpr
 import Platform
 import Reg
diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs
index 5d1148496c..a2cb476e04 100644
--- a/compiler/codeGen/CodeGen/Platform/ARM.hs
+++ b/compiler/codeGen/CodeGen/Platform/ARM.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.ARM where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_arm 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/CodeGen/Platform/ARM64.hs b/compiler/codeGen/CodeGen/Platform/ARM64.hs
index c3ebeda6bf..6ace181356 100644
--- a/compiler/codeGen/CodeGen/Platform/ARM64.hs
+++ b/compiler/codeGen/CodeGen/Platform/ARM64.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.ARM64 where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_aarch64 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
index 0c85ffbda7..4c074ee313 100644
--- a/compiler/codeGen/CodeGen/Platform/NoRegs.hs
+++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.NoRegs where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 1
 #include "../../../../includes/CodeGen.Platform.hs"
 
diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs
index 76a2b020ac..f7eae6b4ca 100644
--- a/compiler/codeGen/CodeGen/Platform/PPC.hs
+++ b/compiler/codeGen/CodeGen/Platform/PPC.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.PPC where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_powerpc 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs
index a98e558cc1..91923fd453 100644
--- a/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs
+++ b/compiler/codeGen/CodeGen/Platform/PPC_Darwin.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.PPC_Darwin where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_powerpc 1
 #define MACHREGS_darwin 1
diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs
index 991f515eaf..5d8dbb1da9 100644
--- a/compiler/codeGen/CodeGen/Platform/SPARC.hs
+++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.SPARC where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_sparc 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs
index e74807ff88..84d52c1585 100644
--- a/compiler/codeGen/CodeGen/Platform/X86.hs
+++ b/compiler/codeGen/CodeGen/Platform/X86.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.X86 where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_i386 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs
index 102132d679..1b2b5549ac 100644
--- a/compiler/codeGen/CodeGen/Platform/X86_64.hs
+++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs
@@ -2,6 +2,8 @@
 
 module CodeGen.Platform.X86_64 where
 
+import GhcPrelude
+
 #define MACHREGS_NO_REGS 0
 #define MACHREGS_x86_64 1
 #include "../../../../includes/CodeGen.Platform.hs"
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index d92b410a7f..60be1ca01b 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -12,6 +12,8 @@ module StgCmm ( codeGen ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude as Prelude
+
 import StgCmmProf (initCostCentres, ldvEnter)
 import StgCmmMonad
 import StgCmmEnv
@@ -233,8 +235,8 @@ maybeExternaliseId dflags id
   | gopt Opt_SplitObjs dflags,  -- See Note [Externalise when splitting]
                                 -- in StgCmmMonad
     isInternalName name = do { mod <- getModuleName
-                             ; returnFC (setIdName id (externalise mod)) }
-  | otherwise           = returnFC id
+                             ; return (setIdName id (externalise mod)) }
+  | otherwise           = return id
   where
     externalise mod = mkExternalName uniq mod new_occ loc
     name    = idName id
diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs
index 969e14f79e..2ea04079d0 100644
--- a/compiler/codeGen/StgCmmArgRep.hs
+++ b/compiler/codeGen/StgCmmArgRep.hs
@@ -15,6 +15,8 @@ module StgCmmArgRep (
 
         ) where
 
+import GhcPrelude
+
 import StgCmmClosure    ( idPrimRep )
 
 import SMRep            ( WordOff )
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 31775d6624..aa2b954a95 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -----------------------------------------------------------------------------
 --
 -- Stg to C-- code generation: bindings
@@ -15,14 +13,14 @@ module StgCmmBind (
         pushUpdateFrame, emitUpdateFrame
   ) where
 
-#include "HsVersions.h"
+import GhcPrelude hiding ((<*>))
 
 import StgCmmExpr
 import StgCmmMonad
 import StgCmmEnv
 import StgCmmCon
 import StgCmmHeap
-import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
+import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
                    initUpdFrameProf)
 import StgCmmTicky
 import StgCmmLayout
@@ -53,8 +51,6 @@ import DynFlags
 
 import Control.Monad
 
-import Prelude hiding ((<*>))
-
 ------------------------------------------------------------------------
 --              Top-level bindings
 ------------------------------------------------------------------------
@@ -99,21 +95,20 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
          emitDataLits closure_label closure_rep
          return ()
 
-  gen_code dflags lf_info closure_label
-   = do {     -- LAY OUT THE OBJECT
-          let name = idName id
+  gen_code dflags lf_info _closure_label
+   = do { let name = idName id
         ; mod_name <- getModuleName
         ; let descr         = closureDescription dflags mod_name name
               closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
 
-              caffy         = idCafInfo id
-              info_tbl      = mkCmmInfo closure_info -- XXX short-cut
-              closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []
+        -- We don't generate the static closure here, because we might
+        -- want to add references to static closures to it later.  The
+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,
+        -- See Note [SRTs], specifically the [FUN] optimisation.
 
-                 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
-        ; emitDataLits closure_label closure_rep
-        ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-              (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) []
+        ; let fv_details :: [(NonVoid Id, ByteOff)]
+              header = if isLFThunk lf_info then ThunkHeader else StdHeader
+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []
         -- Don't drop the non-void args until the closure info has been made
         ; forkClosureBody (closureCodeBody True id closure_info ccs
                                 (nonVoidIds args) (length args) body fv_details)
@@ -350,9 +345,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
                 fv_details :: [(NonVoid Id, ByteOff)]
+                header = if isLFThunk lf_info then ThunkHeader else StdHeader
                 (tot_wds, ptr_wds, fv_details)
-                   = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                       (addIdReps reduced_fvs)
+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
                 closure_info = mkClosureInfo dflags False       -- Not static
                                              bndr lf_info tot_wds ptr_wds
                                              descr
@@ -367,10 +362,10 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
 
         -- BUILD THE OBJECT
 --      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
-        ; let use_cc = curCCS; blame_cc = curCCS
+        ; let use_cc = cccsExpr; blame_cc = cccsExpr
         ; emit (mkComment $ mkFastString "calling allocDynClosure")
         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
-        ; let info_tbl = mkCmmInfo closure_info
+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
         ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
@@ -395,9 +390,10 @@ cgRhsStdThunk bndr lf_info payload
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
-  ; let (tot_wds, ptr_wds, payload_w_offsets)
-            = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                (addArgReps (nonVoidStgArgs payload))
+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
+        (tot_wds, ptr_wds, payload_w_offsets)
+            = mkVirtHeapOffsets dflags header
+                (addArgReps (nonVoidStgArgs payload))
 
         descr = closureDescription dflags mod_name (idName bndr)
         closure_info = mkClosureInfo dflags False       -- Not static
@@ -405,11 +401,11 @@ cgRhsStdThunk bndr lf_info payload
                                      descr
 
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
-  ; let use_cc = curCCS; blame_cc = curCCS
+  ; let use_cc = cccsExpr; blame_cc = cccsExpr
 
 
         -- BUILD THE OBJECT
-  ; let info_tbl = mkCmmInfo closure_info
+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
   ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
@@ -465,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
      lf_info  = closureLFInfo cl_info
-     info_tbl = mkCmmInfo cl_info
+     info_tbl = mkCmmInfo cl_info bndr cc
 
 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   = -- Note: args may be [], if all args are Void
@@ -476,7 +472,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
         ; let
              lf_info  = closureLFInfo cl_info
-             info_tbl = mkCmmInfo cl_info
+             info_tbl = mkCmmInfo cl_info bndr cc
 
         -- Emit the main entry code
         ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
@@ -632,8 +628,7 @@ emitBlackHoleCode node = do
              -- work with profiling.
 
   when eager_blackholing $ do
-    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
-                  (CmmReg (CmmGlobal CurrentTSO))
+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
     emitPrimCall [] MO_WriteBarrier []
     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
 
@@ -718,7 +713,7 @@ link_caf node _is_upd = do
                                     ForeignLabelInExternalPackage IsFunction
   ; bh <- newTemp (bWord dflags)
   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
-      [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
+      [ (baseExpr,  AddrHint),
         (CmmReg (CmmLocal node), AddrHint) ]
       False
 
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 8eaee795a5..6f0feaa557 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -27,7 +27,7 @@ module StgCmmClosure (
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
         mkLFStringLit,
         lfDynTag,
-        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
+        isLFThunk, isLFReEntrant, lfUpdatable,
 
         -- * Used by other modules
         CgLoc(..), SelfLoopInfo, CallMethod(..),
@@ -66,11 +66,14 @@ module StgCmmClosure (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 import SMRep
 import Cmm
 import PprCmmExpr()
 
+import CostCentre
 import BlockId
 import CLabel
 import Id
@@ -384,11 +387,6 @@ lfDynTag _      _other                      = 0
 --                Observing LambdaFormInfo
 -----------------------------------------------------------------------------
 
--------------
-maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon
-maybeIsLFCon (LFCon con) = Just con
-maybeIsLFCon _ = Nothing
-
 ------------
 isLFThunk :: LambdaFormInfo -> Bool
 isLFThunk (LFThunk {})  = True
@@ -748,12 +746,15 @@ data ClosureInfo
     }
 
 -- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
-mkCmmInfo :: ClosureInfo -> CmmInfoTable
-mkCmmInfo ClosureInfo {..}
+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
+mkCmmInfo ClosureInfo {..} id ccs
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = if isStaticRep closureSMRep
+                                then Just (id,ccs)
+                                else Nothing }
 
 --------------------------------------
 --        Building ClosureInfos
@@ -1038,7 +1039,8 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
-                , cit_srt  = NoC_SRT }
+                , cit_srt  = Nothing
+                , cit_clo  = Nothing }
  where
    name = dataConName data_con
    info_lbl = mkConInfoTableLabel name NoCafRefs
@@ -1061,14 +1063,16 @@ cafBlackHoleInfoTable
   = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
                  , cit_rep  = blackHoleRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 indStaticInfoTable :: CmmInfoTable
 indStaticInfoTable
   = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
                  , cit_rep  = indStaticRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
 
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
@@ -1079,4 +1083,4 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- of the SRT.
 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+  | otherwise              = has_srt
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index a76b8cc0a0..a8ec300157 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -17,6 +17,8 @@ module StgCmmCon (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 import CoreSyn  ( AltCon(..) )
 
@@ -26,9 +28,9 @@ import StgCmmHeap
 import StgCmmLayout
 import StgCmmUtils
 import StgCmmClosure
-import StgCmmProf ( curCCS )
 
 import CmmExpr
+import CmmUtils
 import CLabel
 import MkGraph
 import SMRep
@@ -79,7 +81,15 @@ cgTopRhsCon dflags id con args =
         ; let
             (tot_wds, --  #ptr_wds + #nonptr_wds
              ptr_wds, --  #ptr_wds
-             nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)
+             nv_args_w_offsets) =
+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
+
+            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
+            mk_payload (FieldOff arg _) = do
+                amode <- getArgAmode arg
+                case amode of
+                  CmmLit lit -> return lit
+                  _          -> panic "StgCmmCon.cgTopRhsCon"
 
             nonptr_wds = tot_wds - ptr_wds
 
@@ -88,10 +98,8 @@ cgTopRhsCon dflags id con args =
              -- needs to poke around inside it.
             info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
 
-            get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
-                                        ; return lit }
 
-        ; payload <- mapM get_lit nv_args_w_offsets
+        ; payload <- mapM mk_payload nv_args_w_offsets
                 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
                 -- NB2: all the amodes should be Lits!
                 --      TODO (osa): Why?
@@ -191,8 +199,8 @@ because they don't support cross package data references well.
 
 buildDynCon' dflags platform binder _ _cc con [arg]
   | maybeIntLikeCon con
-  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
-  , NonVoid (StgLitArg (MachInt val)) <- arg
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
   , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
   , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
   = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
@@ -205,7 +213,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
 
 buildDynCon' dflags platform binder _ _cc con [arg]
   | maybeCharLikeCon con
-  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
   , NonVoid (StgLitArg (MachChar val)) <- arg
   , let val_int = ord val :: Int
   , val_int <= mAX_CHARLIKE dflags
@@ -239,7 +247,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args
           ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
     where
       use_cc      -- cost-centre to stick in the object
-        | isCurrentCCS ccs = curCCS
+        | isCurrentCCS ccs = cccsExpr
         | otherwise        = panic "buildDynCon: non-current CCS not implemented"
 
       blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
@@ -262,7 +270,7 @@ bindConArgs (DataAlt con) base args
 
            -- The binding below forces the masking out of the tag bits
            -- when accessing the constructor field.
-           bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode (Maybe LocalReg)
+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
            bind_arg (arg@(NonVoid b), offset)
              | isDeadBinder b =
                  -- Do not load unused fields from objects to local variables.
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 3061fb351b..f27728189f 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -24,6 +24,8 @@ module StgCmmEnv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TyCon
 import StgCmmMonad
 import StgCmmUtils
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 6e6ad7e9d7..22fcfaf412 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
 
 -----------------------------------------------------------------------------
 --
@@ -13,6 +12,8 @@ module StgCmmExpr ( cgExpr ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude hiding ((<*>))
+
 import {-# SOURCE #-} StgCmmBind ( cgBind )
 
 import StgCmmMonad
@@ -51,8 +52,6 @@ import Control.Monad (unless,void)
 import Control.Arrow (first)
 import Data.Function ( on )
 
-import Prelude hiding ((<*>))
-
 ------------------------------------------------------------------------
 --              cgExpr: the main function
 ------------------------------------------------------------------------
@@ -61,7 +60,8 @@ cgExpr  :: StgExpr -> FCode ReturnKind
 
 cgExpr (StgApp fun args)     = cgIdApp fun args
 
-{- seq# a s ==> a -}
+-- seq# a s ==> a
+-- See Note [seq# magic] in PrelRules
 cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
   cgIdApp a []
 
@@ -409,7 +409,8 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
        ; v_info <- getCgIdInfo v
        ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
                     (idInfoToAmode v_info)
-       ; bindArgToReg (NonVoid bndr)
+       -- Add bndr to the environment
+       ; _ <- bindArgToReg (NonVoid bndr)
        ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
   where
     reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
@@ -435,7 +436,8 @@ it would be better to invoke some kind of panic function here.
 cgCase scrut@(StgApp v []) _ (PrimAlt _) _
   = do { dflags <- getDynFlags
        ; mb_cc <- maybeSaveCostCentre True
-       ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
+       ; _ <- withSequel
+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
        ; restoreCurrentCostCentre mb_cc
        ; emitComment $ mkFastString "should be unreachable code"
        ; l <- newBlockId
@@ -446,13 +448,14 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
 
 {- Note [Handle seq#]
 ~~~~~~~~~~~~~~~~~~~~~
-case seq# a s of v
-  (# s', a' #) -> e
+See Note [seq# magic] in PrelRules.
+The special case for seq# in cgCase does this:
 
+  case seq# a s of v
+    (# s', a' #) -> e
 ==>
-
-case a of v
-  (# s', a' #) -> e
+  case a of v
+    (# s', a' #) -> e
 
 (taking advantage of the fact that the return convention for (# State#, a #)
 is the same as the return convention for just 'a')
@@ -460,6 +463,7 @@ is the same as the return convention for just 'a')
 
 cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
   = -- Note [Handle seq#]
+    -- And see Note [seq# magic] in PrelRules
     -- Use the same return convention as vanilla 'a'.
     cgCase (StgApp a []) bndr alt_type alts
 
@@ -616,13 +620,12 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
                    branches' = [(tag+1,branch) | (tag,branch) <- branches]
                 emitSwitch tag_expr branches' mb_deflt 1 fam_sz
 
-           else         -- No, get tag from info table
-                do dflags <- getDynFlags
-                   let -- Note that ptr _always_ has tag 1
-                       -- when the family size is big enough
-                       untagged_ptr = cmmRegOffB bndr_reg (-1)
-                       tag_expr = getConstrTag dflags (untagged_ptr)
-                   emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+           else -- No, get tag from info table
+                let -- Note that ptr _always_ has tag 1
+                    -- when the family size is big enough
+                    untagged_ptr = cmmRegOffB bndr_reg (-1)
+                    tag_expr = getConstrTag dflags (untagged_ptr)
+                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
 
         ; return AssignedDirectly }
 
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index f12ada242b..551535d758 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -36,6 +36,8 @@ module StgCmmExtCode (
 
 where
 
+import GhcPrelude
+
 import qualified StgCmmMonad as F
 import StgCmmMonad (FCode, newUnique)
 
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 2e3ed39a37..c1103e7d77 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -----------------------------------------------------------------------------
 --
 -- Code generation for foreign calls.
@@ -20,10 +18,10 @@ module StgCmmForeign (
   emitCloseNursery,
  ) where
 
-#include "HsVersions.h"
+import GhcPrelude hiding( succ, (<*>) )
 
 import StgSyn
-import StgCmmProf (storeCurCCS, ccsType, curCCS)
+import StgCmmProf (storeCurCCS, ccsType)
 import StgCmmEnv
 import StgCmmMonad
 import StgCmmUtils
@@ -48,8 +46,6 @@ import BasicTypes
 
 import Control.Monad
 
-import Prelude hiding( succ, (<*>) )
-
 -----------------------------------------------------------------------------
 -- Code generation for Foreign Calls
 -----------------------------------------------------------------------------
@@ -287,7 +283,7 @@ saveThreadState dflags = do
   close_nursery <- closeNursery dflags tso
   pure $ catAGraphs [
     -- tso = CurrentTSO;
-    mkAssign (CmmLocal tso) stgCurrentTSO,
+    mkAssign (CmmLocal tso) currentTSOExpr,
     -- tso->stackobj->sp = Sp;
     mkStore (cmmOffset dflags
                        (CmmLoad (cmmOffset dflags
@@ -295,11 +291,11 @@ saveThreadState dflags = do
                                            (tso_stackobj dflags))
                                 (bWord dflags))
                        (stack_SP dflags))
-            stgSp,
+            spExpr,
     close_nursery,
     -- 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
+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
       else mkNop
     ]
 
@@ -308,7 +304,7 @@ emitCloseNursery = do
   dflags <- getDynFlags
   tso <- newTemp (bWord dflags)
   code <- closeNursery dflags tso
-  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
 
 {- |
 @closeNursery dflags tso@ produces code to close the nursery.
@@ -336,14 +332,14 @@ closeNursery df tso = do
   let tsoreg  = CmmLocal tso
   cnreg      <- CmmLocal <$> newTemp (bWord df)
   pure $ catAGraphs [
-    mkAssign cnreg stgCurrentNursery,
+    mkAssign cnreg currentNurseryExpr,
 
     -- CurrentNursery->free = Hp+1;
-    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1),
+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
 
     let alloc =
            CmmMachOp (mo_wordSub df)
-              [ cmmOffsetW df stgHp 1
+              [ cmmOffsetW df hpExpr 1
               , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
               ]
 
@@ -370,18 +366,18 @@ loadThreadState dflags = do
   open_nursery <- openNursery dflags tso
   pure $ catAGraphs [
     -- tso = CurrentTSO;
-    mkAssign (CmmLocal tso) stgCurrentTSO,
+    mkAssign (CmmLocal tso) currentTSOExpr,
     -- 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)),
+    mkAssign spReg (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))
+    mkAssign spLimReg (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),
+    mkAssign hpAllocReg (zeroExpr dflags),
     open_nursery,
     -- and load the current cost centre stack from the TSO when profiling:
     if gopt Opt_SccProfilingOn dflags
@@ -397,7 +393,7 @@ emitOpenNursery = do
   dflags <- getDynFlags
   tso <- newTemp (bWord dflags)
   code <- openNursery dflags tso
-  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
 
 {- |
 @openNursery dflags tso@ produces code to open the nursery. A local register
@@ -408,8 +404,8 @@ Opening the nursery corresponds to the following code:
 @
    tso = CurrentTSO;
    cn = CurrentNursery;
-   bdfree = CurrentNuresry->free;
-   bdstart = CurrentNuresry->start;
+   bdfree = CurrentNursery->free;
+   bdstart = CurrentNursery->start;
 
    // We *add* the currently occupied portion of the nursery block to
    // the allocation limit, because we will subtract it again in
@@ -439,17 +435,17 @@ openNursery df tso = do
   -- what code we generate, look at the assembly for
   -- stg_returnToStackTop in rts/StgStartup.cmm.
   pure $ catAGraphs [
-     mkAssign cnreg stgCurrentNursery,
+     mkAssign cnreg currentNurseryExpr,
      mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),
 
      -- Hp = CurrentNursery->free - 1;
-     mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+     mkAssign hpReg (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
+     mkAssign hpLimReg
          (cmmOffsetExpr df
              (CmmReg bdstartreg)
              (cmmOffset df
@@ -496,21 +492,6 @@ stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
 closureField :: DynFlags -> ByteOff -> ByteOff
 closureField dflags off = off + fixedHdrSize dflags
 
-stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp             = CmmReg sp
-stgHp             = CmmReg hp
-stgCurrentTSO     = CmmReg currentTSO
-stgCurrentNursery = CmmReg currentNursery
-
-sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
-sp                = CmmGlobal Sp
-spLim             = CmmGlobal SpLim
-hp                = CmmGlobal Hp
-hpLim             = CmmGlobal HpLim
-currentTSO        = CmmGlobal CurrentTSO
-currentNursery    = CmmGlobal CurrentNursery
-hpAlloc           = CmmGlobal HpAlloc
-
 -- -----------------------------------------------------------------------------
 -- For certain types passed to foreign calls, we adjust the actual
 -- value passed to the call.  For ByteArray#/Array# we pass the
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index db62985e3c..3be35b35fa 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -----------------------------------------------------------------------------
 --
 -- Stg to C--: heap management functions
@@ -22,7 +20,7 @@ module StgCmmHeap (
         emitSetDynHdr
     ) where
 
-#include "HsVersions.h"
+import GhcPrelude hiding ((<*>))
 
 import StgSyn
 import CLabel
@@ -49,8 +47,6 @@ import DynFlags
 import FastString( mkFastString, fsLit )
 import Panic( sorry )
 
-import Prelude hiding ((<*>))
-
 import Control.Monad (when)
 import Data.Maybe (isJust)
 
@@ -149,7 +145,7 @@ emitSetDynHdr base info_ptr ccs
   where
     header :: DynFlags -> [CmmExpr]
     header dflags = [info_ptr] ++ dynProfHdr dflags ccs
-        -- ToDof: Parallel stuff
+        -- ToDo: Parallel stuff
         -- No ticky header
 
 -- Store the item (expr,off) in base[off]
@@ -221,24 +217,11 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
 mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
   =  [CmmLabel info_lbl]
   ++ staticProfHdr dflags ccs
-  ++ concatMap (padLitToWord dflags) payload
+  ++ payload
   ++ padding
   ++ static_link_field
   ++ saved_info_field
 
--- JD: Simon had ellided this padding, but without it the C back end asserts
--- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?
-padLitToWord :: DynFlags -> CmmLit -> [CmmLit]
-padLitToWord dflags lit = lit : padding pad_length
-  where width = typeWidth (cmmLitType dflags lit)
-        pad_length = wORD_SIZE dflags - widthInBytes width :: Int
-
-        padding n | n <= 0 = []
-                  | n `rem` 2 /= 0 = CmmInt 0 W8  : padding (n-1)
-                  | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
-                  | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
-                  | otherwise      = CmmInt 0 W64 : padding (n-8)
-
 -----------------------------------------------------------
 --              Heap overflow checking
 -----------------------------------------------------------
@@ -616,7 +599,7 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
   let
     Just alloc_lit = mb_alloc_lit
 
-    bump_hp   = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
+    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit
 
     -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
     -- At the beginning of a function old + 0 = Sp
@@ -630,10 +613,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
     -- Hp overflow if (Hp > HpLim)
     -- (Hp has been incremented by now)
     -- HpLim points to the LAST WORD of valid allocation space.
-    hp_oflo = CmmMachOp (mo_wordUGt dflags)
-                  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]
 
-    alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
+    alloc_n = mkAssign hpAllocReg alloc_lit
 
   case mb_stk_hwm of
     Nothing -> return ()
@@ -658,7 +640,7 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
       when (checkYield && not (gopt Opt_OmitYields dflags)) $ do
          -- Yielding if HpLim == 0
          let yielding = CmmMachOp (mo_wordEq dflags)
-                                  [CmmReg (CmmGlobal HpLim),
+                                  [CmmReg hpLimReg,
                                    CmmLit (zeroCLit dflags)]
          emit =<< mkCmmIfGoto' yielding gc_id (Just False)
 
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index c8e65ad126..8e9676bd33 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -8,6 +8,8 @@
 
 module StgCmmHpc ( initHpc, mkTickBox ) where
 
+import GhcPrelude
+
 import StgCmmMonad
 
 import MkGraph
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index b123420d58..78a7cf3f85 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 
 -----------------------------------------------------------------------------
@@ -17,7 +18,13 @@ module StgCmmLayout (
 
         slowCall, directCall,
 
-        mkVirtHeapOffsets, mkVirtConstrOffsets, mkVirtConstrSizes, getHpRelOffset,
+        FieldOffOrPadding(..),
+        ClosureHeader(..),
+        mkVirtHeapOffsets,
+        mkVirtHeapOffsetsWithPadding,
+        mkVirtConstrOffsets,
+        mkVirtConstrSizes,
+        getHpRelOffset,
 
         ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep
   ) where
@@ -25,7 +32,7 @@ module StgCmmLayout (
 
 #include "HsVersions.h"
 
-import Prelude hiding ((<*>))
+import GhcPrelude hiding ((<*>))
 
 import StgCmmClosure
 import StgCmmEnv
@@ -33,7 +40,6 @@ import StgCmmArgRep -- notably: ( slowCallPattern )
 import StgCmmTicky
 import StgCmmMonad
 import StgCmmUtils
-import StgCmmProf (curCCS)
 
 import MkGraph
 import SMRep
@@ -44,7 +50,7 @@ import CmmInfo
 import CLabel
 import StgSyn
 import Id
-import TyCon             ( PrimRep(..) )
+import TyCon             ( PrimRep(..), primRepSizeB )
 import BasicTypes        ( RepArity )
 import DynFlags
 import Module
@@ -367,7 +373,7 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not
 
     stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
     this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
     save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
 
 -------------------------------------------------------------------------
@@ -387,30 +393,47 @@ getHpRelOffset virtual_offset
        hp_usg <- getHpUsage
        return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
 
-mkVirtHeapOffsets
+data FieldOffOrPadding a
+    = FieldOff (NonVoid a) -- Something that needs an offset.
+               ByteOff     -- Offset in bytes.
+    | Padding ByteOff  -- Length of padding in bytes.
+              ByteOff  -- Offset in bytes.
+
+-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
+-- of header the object has.  This will be accounted for in the
+-- offsets of the fields returned.
+data ClosureHeader
+  = NoHeader
+  | StdHeader
+  | ThunkHeader
+
+mkVirtHeapOffsetsWithPadding
   :: DynFlags
-  -> Bool                     -- True <=> is a thunk
-  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
-  -> (WordOff,                -- _Total_ number of words allocated
-      WordOff,                -- Number of words allocated for *pointers*
-      [(NonVoid a, ByteOff)])
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
+  -> ( WordOff                -- Total number of words allocated
+     , WordOff                -- Number of words allocated for *pointers*
+     , [FieldOffOrPadding a]  -- Either an offset or padding.
+     )
 
 -- Things with their offsets from start of object in order of
 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
 -- First in list gets lowest offset, which is initial offset + 1.
 --
--- mkVirtHeapOffsets always returns boxed things with smaller offsets
+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
 -- than the unboxed things
 
-mkVirtHeapOffsets dflags is_thunk things
-  = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
-    ( bytesToWordsRoundUp dflags tot_bytes
+mkVirtHeapOffsetsWithPadding dflags header things =
+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
+    ( tot_wds
     , bytesToWordsRoundUp dflags bytes_of_ptrs
-    , ptrs_w_offsets ++ non_ptrs_w_offsets
+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
     )
   where
-    hdr_words | is_thunk   = thunkHdrSize dflags
-              | otherwise  = fixedHdrSizeW dflags
+    hdr_words = case header of
+      NoHeader -> 0
+      StdHeader -> fixedHdrSizeW dflags
+      ThunkHeader -> thunkHdrSize dflags
     hdr_bytes = wordsToBytes dflags hdr_words
 
     (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
@@ -420,16 +443,64 @@ mkVirtHeapOffsets dflags is_thunk things
     (tot_bytes, non_ptrs_w_offsets) =
        mapAccumL computeOffset bytes_of_ptrs non_ptrs
 
-    computeOffset bytes_so_far nv_thing
-      = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
-         (NonVoid thing, hdr_bytes + bytes_so_far))
-           where (rep,thing) = fromNonVoid nv_thing
+    tot_wds = bytesToWordsRoundUp dflags tot_bytes
+
+    final_pad_size = tot_wds * word_size - tot_bytes
+    final_pad
+        | final_pad_size > 0 = [(Padding final_pad_size
+                                         (hdr_bytes + tot_bytes))]
+        | otherwise          = []
+
+    word_size = wORD_SIZE dflags
+
+    computeOffset bytes_so_far nv_thing =
+        (new_bytes_so_far, with_padding field_off)
+      where
+        (rep, thing) = fromNonVoid nv_thing
+
+        -- Size of the field in bytes.
+        !sizeB = primRepSizeB dflags rep
+
+        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
+        -- But not more than to a word.
+        !align = min word_size sizeB
+        !start = roundUpTo bytes_so_far align
+        !padding = start - bytes_so_far
+
+        -- Final offset is:
+        --   size of header + bytes_so_far + padding
+        !final_offset = hdr_bytes + bytes_so_far + padding
+        !new_bytes_so_far = start + sizeB
+        field_off = FieldOff (NonVoid thing) final_offset
+
+        with_padding field_off
+            | padding == 0 = [field_off]
+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
+                             , field_off
+                             ]
+
+
+mkVirtHeapOffsets
+  :: DynFlags
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
+  -> (WordOff,                -- _Total_ number of words allocated
+      WordOff,                -- Number of words allocated for *pointers*
+      [(NonVoid a, ByteOff)])
+mkVirtHeapOffsets dflags header things =
+    ( tot_wds
+    , ptr_wds
+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
+    )
+  where
+   (tot_wds, ptr_wds, things_offsets) =
+       mkVirtHeapOffsetsWithPadding dflags header things
 
 -- | Just like mkVirtHeapOffsets, but for constructors
 mkVirtConstrOffsets
   :: DynFlags -> [NonVoid (PrimRep, a)]
   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader
 
 -- | Just like mkVirtConstrOffsets, but used when we don't have the actual
 -- arguments. Useful when e.g. generating info tables; we just need to know
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 5e62183fb5..9ddd8a3985 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs, UnboxedTuples #-}
+{-# LANGUAGE GADTs, UnboxedTuples #-}
 
 -----------------------------------------------------------------------------
 --
@@ -11,9 +11,8 @@
 module StgCmmMonad (
         FCode,        -- type
 
-        initC, runC, thenC, thenFC, listCs,
-        returnFC, fixC,
-        newUnique, newUniqSupply,
+        initC, runC, fixC,
+        newUnique,
 
         emitLabel,
 
@@ -30,7 +29,7 @@ module StgCmmMonad (
 
         mkCall, mkCmmCall,
 
-        forkClosureBody, forkLneBody, forkAlts, codeOnly,
+        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
 
         ConTagZ,
 
@@ -59,13 +58,12 @@ module StgCmmMonad (
         CgInfoDownwards(..), CgState(..)        -- non-abstract
     ) where
 
-#include "HsVersions.h"
+import GhcPrelude hiding( sequence, succ )
 
 import Cmm
 import StgCmmClosure
 import DynFlags
 import Hoopl.Collections
-import Maybes
 import MkGraph
 import BlockId
 import CLabel
@@ -79,13 +77,11 @@ import Unique
 import UniqSupply
 import FastString
 import Outputable
+import Util
 
 import Control.Monad
 import Data.List
-import Prelude hiding( sequence, succ )
 
-infixr 9 `thenC`        -- Right-associative!
-infixr 9 `thenFC`
 
 
 --------------------------------------------------------
@@ -114,27 +110,30 @@ infixr 9 `thenFC`
 
 --------------------------------------------------------
 
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
+newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
 
 instance Functor FCode where
-  fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
+    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
 
 instance Applicative FCode where
-      pure = returnFC
-      (<*>) = ap
+    pure val = FCode (\_info_down state -> (val, state))
+    {-# INLINE pure #-}
+    (<*>) = ap
 
 instance Monad FCode where
-        (>>=) = thenFC
-
-{-# INLINE thenC #-}
-{-# INLINE thenFC #-}
-{-# INLINE returnFC #-}
+    FCode m >>= k = FCode $
+        \info_down state ->
+            case m info_down state of
+              (m_result, new_state) ->
+                 case k m_result of
+                   FCode kcode -> kcode info_down new_state
+    {-# INLINE (>>=) #-}
 
 instance MonadUnique FCode where
   getUniqueSupplyM = cgs_uniqs <$> getState
   getUniqueM = FCode $ \_ st ->
     let (u, us') = takeUniqFromSupply (cgs_uniqs st)
-    in (# u, st { cgs_uniqs = us' } #)
+    in (u, st { cgs_uniqs = us' })
 
 initC :: IO CgState
 initC  = do { uniqs <- mkSplitUniqSupply 'c'
@@ -143,36 +142,10 @@ initC  = do { uniqs <- mkSplitUniqSupply 'c'
 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
 runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
 
-returnFC :: a -> FCode a
-returnFC val = FCode (\_info_down state -> (# val, state #))
-
-thenC :: FCode () -> FCode a -> FCode a
-thenC (FCode m) (FCode k) =
-        FCode $ \info_down state -> case m info_down state of
-                                     (# _,new_state #) -> k info_down new_state
-
-listCs :: [FCode ()] -> FCode ()
-listCs [] = return ()
-listCs (fc:fcs) = do
-        fc
-        listCs fcs
-
-thenFC  :: FCode a -> (a -> FCode c) -> FCode c
-thenFC (FCode m) k = FCode $
-        \info_down state ->
-            case m info_down state of
-              (# m_result, new_state #) ->
-                 case k m_result of
-                   FCode kcode -> kcode info_down new_state
-
 fixC :: (a -> FCode a) -> FCode a
-fixC fcode = FCode (
-        \info_down state ->
-                let
-                        (v,s) = doFCode (fcode v) info_down state
-                in
-                        (# v, s #)
-        )
+fixC fcode = FCode $
+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state
+                        in (v, s)
 
 --------------------------------------------------------
 --        The code generator environment
@@ -432,10 +405,10 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 --------------------------------------------------------
 
 getState :: FCode CgState
-getState = FCode $ \_info_down state -> (# state, state #)
+getState = FCode $ \_info_down state -> (state, state)
 
 setState :: CgState -> FCode ()
-setState state = FCode $ \_info_down _ -> (# (), state #)
+setState state = FCode $ \_info_down _ -> ((), state)
 
 getHpUsage :: FCode HeapUsage
 getHpUsage = do
@@ -475,7 +448,7 @@ setBinds new_binds = do
 withState :: FCode a -> CgState -> FCode (a,CgState)
 withState (FCode fcode) newstate = FCode $ \info_down state ->
   case fcode info_down newstate of
-    (# retval, state2 #) -> (# (retval,state2), state #)
+    (retval, state2) -> ((retval,state2), state)
 
 newUniqSupply :: FCode UniqSupply
 newUniqSupply = do
@@ -493,7 +466,7 @@ newUnique = do
 
 ------------------
 getInfoDown :: FCode CgInfoDownwards
-getInfoDown = FCode $ \info_down state -> (# info_down,state #)
+getInfoDown = FCode $ \info_down state -> (info_down,state)
 
 getSelfLoop :: FCode (Maybe SelfLoopInfo)
 getSelfLoop = do
@@ -514,11 +487,6 @@ getThisPackage = liftM thisPackage getDynFlags
 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 
-doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
-doFCode (FCode fcode) info_down state =
-  case fcode info_down state of
-    (# a, s #) -> ( a, s )
-
 -- ----------------------------------------------------------------------------
 -- Get the current module name
 
@@ -664,10 +632,19 @@ forkAlts branch_fcodes
                                       , cgs_hp_usg = cgs_hp_usg state }
               (_us, results) = mapAccumL compile us branch_fcodes
               (branch_results, branch_out_states) = unzip results
-        ; setState $ foldl stateIncUsage state branch_out_states
+        ; setState $ foldl' stateIncUsage state branch_out_states
                 -- NB foldl.  state is the *left* argument to stateIncUsage
         ; return branch_results }
 
+forkAltPair :: FCode a -> FCode a -> FCode (a,a)
+-- Most common use of 'forkAlts'; having this helper function avoids
+-- accidental use of failible pattern-matches in @do@-notation
+forkAltPair x y = do
+  xy' <- forkAlts [x,y]
+  case xy' of
+    [x',y'] -> return (x',y')
+    _ -> panic "forkAltPair"
+
 -- collect the code emitted by an FCode computation
 getCodeR :: FCode a -> FCode (a, CmmAGraph)
 getCodeR fcode
@@ -727,11 +704,9 @@ emitLabel id = do tscope <- getTickScope
                   emitCgStmt (CgLabel id tscope)
 
 emitComment :: FastString -> FCode ()
-#if 0 /* def DEBUG */
-emitComment s = emitCgStmt (CgStmt (CmmComment s))
-#else
-emitComment _ = return ()
-#endif
+emitComment s
+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))
+  | otherwise = return ()
 
 emitTick :: CmmTickish -> FCode ()
 emitTick = emitCgStmt . CgStmt . CmmTick
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 1ecd72f9db..266ab3a0f6 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP #-}
+-- emitPrimOp is quite large
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}
 
 ----------------------------------------------------------------------------
 --
@@ -17,6 +19,8 @@ module StgCmmPrim (
 
 #include "HsVersions.h"
 
+import GhcPrelude hiding ((<*>))
+
 import StgCmmLayout
 import StgCmmForeign
 import StgCmmEnv
@@ -24,7 +28,7 @@ import StgCmmMonad
 import StgCmmUtils
 import StgCmmTicky
 import StgCmmHeap
-import StgCmmProf ( costCentreFrom, curCCS )
+import StgCmmProf ( costCentreFrom )
 
 import DynFlags
 import Platform
@@ -44,10 +48,8 @@ import FastString
 import Outputable
 import Util
 
-import Prelude hiding ((<*>))
-
 import Data.Bits ((.&.), bit)
-import Control.Monad (liftM, when)
+import Control.Monad (liftM, when, unless)
 
 ------------------------------------------------------------------------
 --      Primitive operations and foreign calls
@@ -192,7 +194,7 @@ shouldInlinePrimOp _ CopyMutableArrayArrayOp
 
 shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
 
 shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
@@ -200,7 +202,7 @@ shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w
 
 shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
 
 shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
@@ -225,7 +227,7 @@ shouldInlinePrimOp _ CopySmallMutableArrayOp
 
 shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
 
 shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
@@ -233,7 +235,7 @@ shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmIn
 
 shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
 
 shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
   | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
@@ -281,7 +283,7 @@ emitPrimOp _ [res] ParOp [arg]
     emitCCall
         [(res,NoHint)]
         (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
-        [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
+        [(baseExpr, AddrHint), (arg,AddrHint)]
 
 emitPrimOp dflags [res] SparkOp [arg]
   = do
@@ -293,7 +295,7 @@ emitPrimOp dflags [res] SparkOp [arg]
         emitCCall
             [(tmp2,NoHint)]
             (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
-            [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
         emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
 
 emitPrimOp dflags [res] GetCCSOfOp [arg]
@@ -304,7 +306,10 @@ emitPrimOp dflags [res] GetCCSOfOp [arg]
      | otherwise                      = CmmLit (zeroCLit dflags)
 
 emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
-   = emitAssign (CmmLocal res) curCCS
+   = emitAssign (CmmLocal res) cccsExpr
+
+emitPrimOp _ [res] MyThreadIdOp []
+   = emitAssign (CmmLocal res) currentTSOExpr
 
 emitPrimOp dflags [res] ReadMutVarOp [mutv]
    = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
@@ -317,7 +322,7 @@ emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]
         emitCCall
                 [{-no results-}]
                 (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
-                [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
+                [(baseExpr, AddrHint), (mutv,AddrHint)]
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrBytes *)(a))->bytes
@@ -347,14 +352,6 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg]
 emitPrimOp dflags [res] StableNameToIntOp [arg]
    = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
 
---  #define eqStableNamezh(r,sn1,sn2)                                   \
---    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
-emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
-   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
-                                   cmmLoadIndexW dflags arg1 (fixedHdrSizeW dflags) (bWord dflags),
-                                   cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)
-                         ])
-
 emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
    = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
 
@@ -378,20 +375,20 @@ emitPrimOp dflags [res] DataToTagOp [arg]
 
 --  #define unsafeFreezzeArrayzh(r,a)
 --      {
---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);
 --        r = a;
 --      }
 emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]
    = emit $ catAGraphs
-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
      mkAssign (CmmLocal res) arg ]
 emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]
    = emit $ catAGraphs
-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN0_infoLabel)),
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
      mkAssign (CmmLocal res) arg ]
 emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]
    = emit $ catAGraphs
-   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN0_infoLabel)),
+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),
      mkAssign (CmmLocal res) arg ]
 
 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
@@ -516,6 +513,40 @@ emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp
 emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
 emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
 
+-- IndexWord8ArrayAsXXX
+
+emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
+-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
+
+emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
 -- WriteXXXoffAddr
 
 emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
@@ -554,6 +585,23 @@ emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayO
 emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
 emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args
 
+-- WriteInt8ArrayAsXXX
+
+emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args
+
 -- Copying and setting byte arrays
 emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =
     doCopyByteArrayOp src src_off dst dst_off n
@@ -568,6 +616,10 @@ emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =
 emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =
     doSetByteArrayOp ba off len c
 
+-- Comparing byte arrays
+emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =
+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n
+
 emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16
 emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32
 emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64
@@ -580,6 +632,20 @@ emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
 emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
 emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
 
+-- Parallel bit deposit
+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8
+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16
+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32
+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64
+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)
+
+-- Parallel bit extract
+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8
+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16
+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32
+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64
+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)
+
 -- count leading zeros
 emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8
 emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16
@@ -833,6 +899,11 @@ callishPrimOpSupported dflags op
                          || llvm      -> Left (MO_Add2       (wordWidth dflags))
                      | otherwise      -> Right genericWordAdd2Op
 
+      WordAddCOp     | (ncg && (x86ish
+                                || ppc))
+                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordAddCOp
+
       WordSubCOp     | (ncg && (x86ish
                                 || ppc))
                          || llvm      -> Left (MO_SubWordC   (wordWidth dflags))
@@ -969,17 +1040,64 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
                    (bottomHalf (CmmReg (CmmLocal r1))))]
 genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
 
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:
+--
+-- @
+--    c = a&b | (a|b)&~r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
+genericWordAddCOp :: GenericOp
+genericWordAddCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [aa,bb],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [aa,bb],
+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericWordAddCOp _ _ = panic "genericWordAddCOp"
+
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:
+--
+-- @
+--    c = ~a&b | (~a|b)&r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
 genericWordSubCOp :: GenericOp
-genericWordSubCOp [res_r, res_c] [aa, bb] = do
-  dflags <- getDynFlags
-  emit $ catAGraphs
-    [ -- Put the result into 'res_r'.
-      mkAssign (CmmLocal res_r) $
-        CmmMachOp (mo_wordSub dflags) [aa, bb]
-      -- Set 'res_c' to 1 if 'bb > aa' and to 0 otherwise.
-    , mkAssign (CmmLocal res_c) $
-        CmmMachOp (mo_wordUGt dflags) [bb, aa]
-    ]
+genericWordSubCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordNot dflags) [aa],
+                bb
+              ],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [
+                  CmmMachOp (mo_wordNot dflags) [aa],
+                  bb
+                ],
+                CmmReg (CmmLocal res_r)
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
 genericWordSubCOp _ _ = panic "genericWordSubCOp"
 
 genericIntAddCOp :: GenericOp
@@ -1279,9 +1397,22 @@ translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
 translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)
 translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
 translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
+-- See Note [Comparing stable names]
+translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)
 
 translateOp _      _ = Nothing
 
+-- Note [Comparing stable names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A StableName# is actually a pointer to a stable name object (SNO)
+-- containing an index into the stable name table (SNT). We
+-- used to compare StableName#s by following the pointers to the
+-- SNOs and checking whether they held the same SNT indices. However,
+-- this is not necessary: there is a one-to-one correspondence
+-- between SNOs and entries in the SNT, so simple pointer equality
+-- does the trick.
+
 -- These primops are implemented by CallishMachOps, because they sometimes
 -- turn into foreign calls depending on the backend.
 
@@ -1296,6 +1427,9 @@ callishOp DoubleTanhOp   = Just MO_F64_Tanh
 callishOp DoubleAsinOp   = Just MO_F64_Asin
 callishOp DoubleAcosOp   = Just MO_F64_Acos
 callishOp DoubleAtanOp   = Just MO_F64_Atan
+callishOp DoubleAsinhOp  = Just MO_F64_Asinh
+callishOp DoubleAcoshOp  = Just MO_F64_Acosh
+callishOp DoubleAtanhOp  = Just MO_F64_Atanh
 callishOp DoubleLogOp    = Just MO_F64_Log
 callishOp DoubleExpOp    = Just MO_F64_Exp
 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
@@ -1310,6 +1444,9 @@ callishOp FloatTanhOp   = Just MO_F32_Tanh
 callishOp FloatAsinOp   = Just MO_F32_Asin
 callishOp FloatAcosOp   = Just MO_F32_Acos
 callishOp FloatAtanOp   = Just MO_F32_Atan
+callishOp FloatAsinhOp  = Just MO_F32_Asinh
+callishOp FloatAcoshOp  = Just MO_F32_Acosh
+callishOp FloatAtanhOp  = Just MO_F32_Atanh
 callishOp FloatLogOp    = Just MO_F32_Log
 callishOp FloatExpOp    = Just MO_F32_Exp
 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
@@ -1712,7 +1849,7 @@ doNewByteArrayOp res_r n = do
 
     let hdr_size = fixedHdrSize dflags
 
-    base <- allocHeapClosure rep info_ptr curCCS
+    base <- allocHeapClosure rep info_ptr cccsExpr
                      [ (mkIntExpr dflags n,
                         hdr_size + oFFSET_StgArrBytes_bytes dflags)
                      ]
@@ -1720,6 +1857,60 @@ doNewByteArrayOp res_r n = do
     emit $ mkAssign (CmmLocal res_r) base
 
 -- ----------------------------------------------------------------------------
+-- Comparing byte arrays
+
+doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                     -> FCode ()
+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
+    dflags <- getDynFlags
+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off
+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off
+
+    -- short-cut in case of equal pointers avoiding a costly
+    -- subroutine call to the memcmp(3) routine; the Cmm logic below
+    -- results in assembly code being generated for
+    --
+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#
+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#
+    --
+    -- that looks like
+    --
+    --          leaq 16(%r14),%rax
+    --          leaq 16(%rsi),%rbx
+    --          xorl %ecx,%ecx
+    --          cmpq %rbx,%rax
+    --          je l_ptr_eq
+    --
+    --          ; NB: the common case (unequal pointers) falls-through
+    --          ; the conditional jump, and therefore matches the
+    --          ; usual static branch prediction convention of modern cpus
+    --
+    --          subq $8,%rsp
+    --          movq %rbx,%rsi
+    --          movq %rax,%rdi
+    --          movl $10,%edx
+    --          xorl %eax,%eax
+    --          call memcmp
+    --          addq $8,%rsp
+    --          movslq %eax,%rax
+    --          movq %rax,%rcx
+    --  l_ptr_eq:
+    --          movq %rcx,%rbx
+    --          jmp *(%rbp)
+
+    l_ptr_eq <- newBlockId
+    l_ptr_ne <- newBlockId
+
+    emit (mkAssign (CmmLocal res) (zeroExpr dflags))
+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)
+                    l_ptr_eq l_ptr_ne (Just False))
+
+    emitLabel l_ptr_ne
+    emitMemcmpCall res ba1_p ba2_p n 1
+
+    emitLabel l_ptr_eq
+
+-- ----------------------------------------------------------------------------
 -- Copying byte arrays
 
 -- | Takes a source 'ByteArray#', an offset in the source array, a
@@ -1749,10 +1940,9 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts [
-            getCode $ emitMemmoveCall dst_p src_p bytes 1,
-            getCode $ emitMemcpyCall  dst_p src_p bytes 1
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p bytes 1)
+            (getCode $ emitMemcpyCall  dst_p src_p bytes 1)
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
@@ -1826,12 +2016,12 @@ doNewArrayOp res_r rep info payload n init = do
         (mkIntExpr dflags (nonHdrSize dflags rep))
         (zeroExpr dflags)
 
-    base <- allocHeapClosure rep info_ptr curCCS payload
+    base <- allocHeapClosure rep info_ptr cccsExpr payload
 
     arr <- CmmLocal `fmap` newTemp (bWord dflags)
     emit $ mkAssign arr base
 
-    -- Initialise all elements of the the array
+    -- Initialise all elements of the array
     p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
     for <- newBlockId
     emitLabel for
@@ -1893,12 +2083,11 @@ doCopyMutableArrayOp = emitCopyArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts [
-            getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
-            (wORD_SIZE dflags),
-            getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
-            (wORD_SIZE dflags)
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
@@ -1956,12 +2145,11 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
     -- TODO: Optimize branch for common case of no aliasing.
     copy src dst dst_p src_p bytes = do
         dflags <- getDynFlags
-        [moveCall, cpyCall] <- forkAlts
-            [ getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
-              (wORD_SIZE dflags)
-            , getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
-              (wORD_SIZE dflags)
-            ]
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
         emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
 
 emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
@@ -2008,7 +2196,7 @@ emitCloneArray info_p res_r src src_off n = do
 
     let hdr_size = fixedHdrSize dflags
 
-    base <- allocHeapClosure rep info_ptr curCCS
+    base <- allocHeapClosure rep info_ptr cccsExpr
                      [ (mkIntExpr dflags n,
                         hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
                      , (mkIntExpr dflags (nonHdrSizeW rep),
@@ -2047,7 +2235,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
 
     let hdr_size = fixedHdrSize dflags
 
-    base <- allocHeapClosure rep info_ptr curCCS
+    base <- allocHeapClosure rep info_ptr cccsExpr
                      [ (mkIntExpr dflags n,
                         hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
                      ]
@@ -2213,6 +2401,30 @@ emitMemsetCall dst c n align = do
         (MO_Memset align)
         [ dst, c, n ]
 
+emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemcmpCall res ptr1 ptr2 n align = do
+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all
+    -- code-gens currently call out to the @memcmp(3)@ C function.
+    -- This was easier than moving the sign-extensions into
+    -- all the code-gens.
+    dflags <- getDynFlags
+    let is32Bit = typeWidth (localRegType res) == W32
+
+    cres <- if is32Bit
+              then return res
+              else newTemp b32
+
+    emitPrimCall
+        [ cres ]
+        (MO_Memcmp align)
+        [ ptr1, ptr2, n ]
+
+    unless is32Bit $ do
+      emit $ mkAssign (CmmLocal res)
+                      (CmmMachOp
+                         (mo_s_32ToWord dflags)
+                         [(CmmReg (CmmLocal cres))])
+
 emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()
 emitBSwapCall res x width = do
     emitPrimCall
@@ -2227,6 +2439,20 @@ emitPopCntCall res x width = do
         (MO_PopCnt width)
         [ x ]
 
+emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPdepCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pdep width)
+        [ x, y ]
+
+emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPextCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pext width)
+        [ x, y ]
+
 emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
 emitClzCall res x width = do
     emitPrimCall
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 434d7b50de..15c31ca59c 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -----------------------------------------------------------------------------
 --
 -- Code generation for profiling
@@ -16,7 +14,7 @@ module StgCmmProf (
         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
         enterCostCentreThunk, enterCostCentreFun,
         costCentreFrom,
-        curCCS, storeCurCCS,
+        storeCurCCS,
         emitSetCCC,
 
         saveCurrentCostCentre, restoreCurrentCostCentre,
@@ -25,7 +23,7 @@ module StgCmmProf (
         ldvEnter, ldvEnterClosure, ldvRecordCreate
   ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import StgCmmClosure
 import StgCmmUtils
@@ -60,11 +58,8 @@ ccsType = bWord
 ccType :: DynFlags -> CmmType -- Type of a cost centre
 ccType = bWord
 
-curCCS :: CmmExpr
-curCCS = CmmReg (CmmGlobal CCCS)
-
 storeCurCCS :: CmmExpr -> CmmAGraph
-storeCurCCS e = mkAssign (CmmGlobal CCCS) e
+storeCurCCS e = mkAssign cccsReg e
 
 mkCCostCentre :: CostCentre -> CmmLit
 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
@@ -91,7 +86,7 @@ initUpdFrameProf :: CmmExpr -> FCode ()
 initUpdFrameProf frame
   = ifProfiling $        -- frame->header.prof.ccs = CCCS
     do dflags <- getDynFlags
-       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
         -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
         -- is unnecessary because it is not used anyhow.
 
@@ -131,7 +126,7 @@ saveCurrentCostCentre
        if not (gopt Opt_SccProfilingOn dflags)
            then return Nothing
            else do local_cc <- newTemp (ccType dflags)
-                   emitAssign (CmmLocal local_cc) curCCS
+                   emitAssign (CmmLocal local_cc) cccsExpr
                    return (Just local_cc)
 
 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
@@ -184,7 +179,7 @@ enterCostCentreFun ccs closure =
     if isCurrentCCS ccs
        then do dflags <- getDynFlags
                emitRtsCall rtsUnitId (fsLit "enterFunCCS")
-                   [(CmmReg (CmmGlobal BaseReg), AddrHint),
+                   [(baseExpr, AddrHint),
                     (costCentreFrom dflags closure, AddrHint)] False
        else return () -- top-level function, nothing to do
 
@@ -207,7 +202,7 @@ ifProfilingL dflags xs
 
 initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
-initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
+initCostCentres (local_CCs, singleton_CCSs)
   = do dflags <- getDynFlags
        when (gopt Opt_SccProfilingOn dflags) $
            do mapM_ emitCostCentreDecl local_CCs
@@ -278,7 +273,7 @@ emitSetCCC cc tick push
       if not (gopt Opt_SccProfilingOn dflags)
           then return ()
           else do tmp <- newTemp (ccsType dflags)
-                  pushCostCentre tmp curCCS cc
+                  pushCostCentre tmp cccsExpr cc
                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
                   when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
 
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 8d86e37ddf..8f3074856a 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE BangPatterns #-}
 
 -----------------------------------------------------------------------------
 --
@@ -104,7 +104,7 @@ module StgCmmTicky (
   tickySlowCall, tickySlowCallPat,
   ) where
 
-#include "HsVersions.h"
+import GhcPrelude
 
 import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )
 import StgCmmClosure
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 237520877f..99fa550b83 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -43,6 +43,8 @@ module StgCmmUtils (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgCmmMonad
 import StgCmmClosure
 import Cmm
@@ -92,10 +94,10 @@ cgLit other_lit   = do dflags <- getDynFlags
 mkSimpleLit :: DynFlags -> Literal -> CmmLit
 mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
 mkSimpleLit dflags MachNullAddr      = zeroCLit dflags
-mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)
-mkSimpleLit _      (MachInt64 i)     = CmmInt i W64
-mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)
-mkSimpleLit _      (MachWord64 i)    = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64
 mkSimpleLit _      (MachFloat r)     = CmmFloat r W32
 mkSimpleLit _      (MachDouble r)    = CmmFloat r W64
 mkSimpleLit _      (MachLabel fs ms fod)
@@ -278,7 +280,7 @@ regTableOffset dflags n =
 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
 get_Regtable_addr_from_offset dflags _rep offset =
     if haveRegBase (targetPlatform dflags)
-    then CmmRegOff (CmmGlobal BaseReg) offset
+    then CmmRegOff baseReg offset
     else regTableOffset dflags offset
 
 
@@ -527,8 +529,7 @@ emitCmmLitSwitch scrut  branches deflt = do
 
     -- We find the necessary type information in the literals in the branches
     let signed = case head branches of
-                    (MachInt _, _) ->   True
-                    (MachInt64 _, _) -> True
+                    (LitNumber nt _ _, _) -> litNumIsSigned nt
                     _ -> False
 
     let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
@@ -583,7 +584,7 @@ mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
 --------------
 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
 label_default _ Nothing
-  = return  Nothing
+  = return Nothing
 label_default join_lbl (Just code)
   = do lbl <- label_code join_lbl code
        return (Just lbl)
diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index 3f429d1ad2..d15da87aac 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -18,6 +18,8 @@ module CoreArity (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreFVs
 import CoreUtils
@@ -521,61 +523,60 @@ mk_cheap_fn dflags cheap_app
 
 
 ----------------------
-findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool)
 -- This implements the fixpoint loop for arity analysis
 -- See Note [Arity analysis]
+-- If findRhsArity e = (n, is_bot) then
+--  (a) any application of e to <n arguments will not do much work,
+--      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)
+--  (b) if is_bot=True, then e applied to n args is guaranteed bottom
 findRhsArity dflags bndr rhs old_arity
-  = go (rhsEtaExpandArity dflags init_cheap_app rhs)
+  = go (get_arity init_cheap_app)
        -- We always call exprEtaExpandArity once, but usually
        -- that produces a result equal to old_arity, and then
        -- we stop right away (since arities should not decrease)
        -- Result: the common case is that there is just one iteration
   where
+    is_lam = has_lam rhs
+
+    has_lam (Tick _ e) = has_lam e
+    has_lam (Lam b e)  = isId b || has_lam e
+    has_lam _          = False
+
     init_cheap_app :: CheapAppFun
     init_cheap_app fn n_val_args
       | fn == bndr = True   -- On the first pass, this binder gets infinite arity
       | otherwise  = isCheapApp fn n_val_args
 
-    go :: Arity -> Arity
-    go cur_arity
-      | cur_arity <= old_arity = cur_arity
-      | new_arity == cur_arity = cur_arity
+    go :: (Arity, Bool) -> (Arity, Bool)
+    go cur_info@(cur_arity, _)
+      | cur_arity <= old_arity = cur_info
+      | new_arity == cur_arity = cur_info
       | otherwise = ASSERT( new_arity < cur_arity )
 #if defined(DEBUG)
                     pprTrace "Exciting arity"
                        (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
-                                                    , ppr rhs])
+                             , ppr rhs])
 #endif
-                    go new_arity
+                    go new_info
       where
-        new_arity = rhsEtaExpandArity dflags cheap_app rhs
+        new_info@(new_arity, _) = get_arity cheap_app
 
         cheap_app :: CheapAppFun
         cheap_app fn n_val_args
           | fn == bndr = n_val_args < cur_arity
           | otherwise  = isCheapApp fn n_val_args
 
--- ^ The Arity returned is the number of value args the
--- expression can be applied to without doing much work
-rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
--- exprEtaExpandArity is used when eta expanding
---      e  ==>  \xy -> e x y
-rhsEtaExpandArity dflags cheap_app e
-  = case (arityType env e) of
-      ATop (os:oss)
-        | isOneShotInfo os || has_lam e -> 1 + length oss
-                                   -- Don't expand PAPs/thunks
-                                   -- Note [Eta expanding thunks]
-        | otherwise       -> 0
-      ATop []             -> 0
-      ABot n              -> n
-  where
-    env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
-             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }
-
-    has_lam (Tick _ e) = has_lam e
-    has_lam (Lam b e)  = isId b || has_lam e
-    has_lam _          = False
+    get_arity :: CheapAppFun -> (Arity, Bool)
+    get_arity cheap_app
+      = case (arityType env rhs) of
+          ABot n -> (n, True)
+          ATop (os:oss) | isOneShotInfo os || is_lam
+                  -> (1 + length oss, False)    -- Don't expand PAPs/thunks
+          ATop _  -> (0,              False)    -- Note [Eta expanding thunks]
+       where
+         env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
+                  , ae_ped_bot  = gopt Opt_PedanticBottoms dflags }
 
 {-
 Note [Arity analysis]
@@ -936,7 +937,7 @@ etaExpand n orig_expr
           -- See Note [Eta expansion and source notes]
           (expr', args) = collectArgs expr
           (ticks, expr'') = stripTicksTop tickishFloatable expr'
-          sexpr = foldl App expr'' args
+          sexpr = foldl' App expr'' args
           retick expr = foldr mkTick expr ticks
 
                                 -- Abstraction    Application
@@ -1036,10 +1037,19 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
        | n == 0
        = (getTCvInScope subst, reverse eis)
 
-       | Just (tv,ty') <- splitForAllTy_maybe ty
-       , let (subst', tv') = Type.substTyVarBndr subst tv
+       | Just (tcv,ty') <- splitForAllTy_maybe ty
+       , let (subst', tcv') = Type.substVarBndr subst tcv
+       = let ((n_subst, n_tcv), n_n)
+               -- We want to have at least 'n' lambdas at the top.
+               -- If tcv is a tyvar, it corresponds to one Lambda (/\).
+               --   And we won't reduce n.
+               -- If tcv is a covar, we could eta-expand the expr with one
+               --   lambda \co:ty. e co. In this case we generate a new variable
+               --   of the coercion type, update the scope, and reduce n by 1.
+               | isTyVar tcv = ((subst', tcv'), n)
+               | otherwise  = (freshEtaId n subst' (varType tcv'), n-1)
            -- Avoid free vars of the original expression
-       = go n subst' ty' (EtaVar tv' : eis)
+         in go n_n n_subst ty' (EtaVar n_tcv : eis)
 
        | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
        , not (isTypeLevPoly arg_ty)
@@ -1122,8 +1132,8 @@ etaBodyForJoinPoint need_args body
       = (reverse rev_bs, e)
     go n ty subst rev_bs e
       | Just (tv, res_ty) <- splitForAllTy_maybe ty
-      , let (subst', tv') = Type.substTyVarBndr subst tv
-      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` Type (mkTyVarTy tv'))
+      , let (subst', tv') = Type.substVarBndr subst tv
+      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')
       | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
       , let (subst', b) = freshEtaId n subst arg_ty
       = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index f5343caf2b..bc54d26ad3 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -37,7 +37,6 @@ module CoreFVs (
         ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
         rulesFreeVarsDSet,
         ruleLhsFreeIds, ruleLhsFreeIdsList,
-        vectsFreeVars,
 
         expr_fvs,
 
@@ -60,6 +59,8 @@ module CoreFVs (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import Id
 import IdInfo
@@ -350,7 +351,7 @@ orphNamesOfType (TyVarTy _)          = emptyNameSet
 orphNamesOfType (LitTy {})           = emptyNameSet
 orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
                                        `unionNameSet` orphNamesOfTypes tys
-orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderKind bndr)
+orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)
                                        `unionNameSet` orphNamesOfType res
 orphNamesOfType (FunTy arg res)      = unitNameSet funTyConName    -- NB!  See Trac #8535
                                        `unionNameSet` orphNamesOfType arg
@@ -365,8 +366,13 @@ orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
 orphNamesOfTypes :: [Type] -> NameSet
 orphNamesOfTypes = orphNamesOfThings orphNamesOfType
 
+orphNamesOfMCo :: MCoercion -> NameSet
+orphNamesOfMCo MRefl    = emptyNameSet
+orphNamesOfMCo (MCo co) = orphNamesOfCo co
+
 orphNamesOfCo :: Coercion -> NameSet
-orphNamesOfCo (Refl _ ty)           = orphNamesOfType ty
+orphNamesOfCo (Refl ty)             = orphNamesOfType ty
+orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco
 orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
 orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
 orphNamesOfCo (ForAllCo _ kind_co co)
@@ -377,20 +383,19 @@ orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orph
 orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
 orphNamesOfCo (SymCo co)            = orphNamesOfCo co
 orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
-orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co
+orphNamesOfCo (NthCo _ _ co)        = orphNamesOfCo co
 orphNamesOfCo (LRCo  _ co)          = orphNamesOfCo co
 orphNamesOfCo (InstCo co arg)       = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
-orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
 orphNamesOfCo (KindCo co)           = orphNamesOfCo co
 orphNamesOfCo (SubCo co)            = orphNamesOfCo co
 orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs
+orphNamesOfCo (HoleCo _)            = emptyNameSet
 
 orphNamesOfProv :: UnivCoProvenance -> NameSet
 orphNamesOfProv UnsafeCoerceProv    = emptyNameSet
 orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co
 orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
 orphNamesOfProv (PluginProv _)      = emptyNameSet
-orphNamesOfProv (HoleProv _)        = emptyNameSet
 
 orphNamesOfCos :: [Coercion] -> NameSet
 orphNamesOfCos = orphNamesOfThings orphNamesOfCo
@@ -513,17 +518,6 @@ put this 'f' in a Rec block, but will mark the binding as a non-rule loop
 breaker, which is perfectly inlinable.
 -}
 
--- |Free variables of a vectorisation declaration
-vectsFreeVars :: [CoreVect] -> VarSet
-vectsFreeVars = mapUnionVarSet vectFreeVars
-  where
-    vectFreeVars (Vect   _ rhs)   = fvVarSet $ filterFV isLocalId $ expr_fvs rhs
-    vectFreeVars (NoVect _)       = noFVs
-    vectFreeVars (VectType _ _ _) = noFVs
-    vectFreeVars (VectClass _)    = noFVs
-    vectFreeVars (VectInst _)     = noFVs
-      -- this function is only concerned with values, not types
-
 {-
 ************************************************************************
 *                                                                      *
@@ -535,14 +529,23 @@ The free variable pass annotates every node in the expression with its
 NON-GLOBAL free variables and type variables.
 -}
 
-type FVAnn = DVarSet
+type FVAnn = DVarSet  -- See Note [The FVAnn invariant]
+
+{- Note [The FVAnn invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Invariant: a FVAnn, say S, is closed:
+  That is: if v is in S,
+           then freevars( v's type/kind ) is also in S
+-}
 
 -- | Every node in a binding group annotated with its
 -- (non-global) free variables, both Ids and TyVars, and type.
 type CoreBindWithFVs = AnnBind Id FVAnn
+
 -- | Every node in an expression annotated with its
 -- (non-global) free variables, both Ids and TyVars, and type.
-type CoreExprWithFVs  = AnnExpr Id FVAnn
+-- NB: see Note [The FVAnn invariant]
+type CoreExprWithFVs  = AnnExpr  Id FVAnn
 type CoreExprWithFVs' = AnnExpr' Id FVAnn
 
 -- | Every node in an expression annotated with its
@@ -696,12 +699,14 @@ freeVarsBind (Rec binds) body_fvs
     rhss2        = map freeVars rhss
     rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
     binders_fvs  = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders
+                   -- See Note [The FVAnn invariant]
     all_fvs      = rhs_body_fvs `unionFVs` binders_fvs
             -- The "delBinderFV" happens after adding the idSpecVars,
             -- since the latter may add some of the binders as fvs
 
 freeVars :: CoreExpr -> CoreExprWithFVs
--- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
+-- ^ Annotate a 'CoreExpr' with its (non-global) free type
+--   and value variables at every tree node.
 freeVars = go
   where
     go :: CoreExpr -> CoreExprWithFVs
@@ -709,7 +714,8 @@ freeVars = go
       | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v)
       | otherwise    = (emptyDVarSet,                 AnnVar v)
       where
-        ty_fvs = dVarTypeTyCoVars v  -- Do we need this?
+        ty_fvs = dVarTypeTyCoVars v
+                 -- See Note [The FVAnn invariant]
 
     go (Lit lit) = (emptyDVarSet, AnnLit lit)
     go (Lam b body)
@@ -719,6 +725,7 @@ freeVars = go
         body'@(body_fvs, _) = go body
         b_ty  = idType b
         b_fvs = tyCoVarsOfTypeDSet b_ty
+                -- See Note [The FVAnn invariant]
 
     go (App fun arg)
       = ( freeVarsOf fun' `unionFVs` freeVarsOf arg'
@@ -731,8 +738,8 @@ freeVars = go
       = ( (bndr `delBinderFV` alts_fvs)
            `unionFVs` freeVarsOf scrut2
            `unionFVs` tyCoVarsOfTypeDSet ty
-          -- don't need to look at (idType bndr)
-          -- b/c that's redundant with scrut
+          -- Don't need to look at (idType bndr)
+          -- because that's redundant with scrut
         , AnnCase scrut2 bndr ty alts2 )
       where
         scrut2 = go scrut
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 2be1020674..21edba1241 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -11,7 +11,7 @@ A ``lint'' pass to check for Core correctness
 module CoreLint (
     lintCoreBindings, lintUnfolding,
     lintPassResult, lintInteractiveExpr, lintExpr,
-    lintAnnots,
+    lintAnnots, lintTypes,
 
     -- ** Debug output
     endPass, endPassIO,
@@ -21,6 +21,8 @@ module CoreLint (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreFVs
 import CoreUtils
@@ -64,10 +66,10 @@ import Demand ( splitStrictSig, isBotRes )
 import HscTypes
 import DynFlags
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import MonadUtils
+import Data.Foldable      ( toList )
+import Data.List.NonEmpty ( NonEmpty )
 import Data.Maybe
 import Pair
 import qualified GHC.LanguageExtensions as LangExt
@@ -200,8 +202,8 @@ points but not the RHSes of value bindings (thunks and functions).
 ************************************************************************
 
 These functions are not CoreM monad stuff, but they probably ought to
-be, and it makes a conveneint place.  place for them.  They print out
-stuff before and after core passes, and do Core Lint when necessary.
+be, and it makes a convenient place for them.  They print out stuff
+before and after core passes, and do Core Lint when necessary.
 -}
 
 endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
@@ -266,13 +268,13 @@ coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
 coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify
 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
-coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
-coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt
 coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
@@ -404,7 +406,8 @@ lintCoreBindings dflags pass local_in_scope binds
   where
     in_scope_set = mkInScopeSet (mkVarSet local_in_scope)
 
-    flags = LF { lf_check_global_ids = check_globals
+    flags = defaultLintFlags
+               { lf_check_global_ids = check_globals
                , lf_check_inline_loop_breakers = check_lbs
                , lf_check_static_ptrs = check_static_ptrs }
 
@@ -455,8 +458,16 @@ lintCoreBindings dflags pass local_in_scope binds
 *                                                                      *
 ************************************************************************
 
-We use this to check all unfoldings that come in from interfaces
-(it is very painful to catch errors otherwise):
+Note [Linting Unfoldings from Interfaces]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We use this to check all top-level unfoldings that come in from interfaces
+(it is very painful to catch errors otherwise).
+
+We do not need to call lintUnfolding on unfoldings that are nested within
+top-level unfoldings; they are linted when we lint the top-level unfolding;
+hence the `TopLevelFlag` on `tcPragExpr` in TcIface.
+
 -}
 
 lintUnfolding :: DynFlags
@@ -508,6 +519,11 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        ; binder_ty <- applySubstTy (idType binder)
        ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
 
+       -- If the binding is for a CoVar, the RHS should be (Coercion co)
+       -- See Note [CoreSyn type and coercion invariant] in CoreSyn
+       ; checkL (not (isCoVar binder) || isCoArg rhs)
+                (mkLetErr binder rhs)
+
        -- Check that it's not levity-polymorphic
        -- Do this first, because otherwise isUnliftedType panics
        -- Annoyingly, this duplicates the test in lintIdBdr,
@@ -520,7 +536,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        ; checkL ( isJoinId binder
                || not (isUnliftedType binder_ty)
                || (isNonRec rec_flag && exprOkForSpeculation rhs)
-               || exprIsLiteralString rhs)
+               || exprIsTickedString rhs)
            (badBndrTyMsg binder (text "unlifted"))
 
         -- Check that if the binder is top-level or recursive, it's not
@@ -528,14 +544,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
         -- computation to perform, see Note [CoreSyn top-level string literals].
        ; checkL (not (isStrictId binder)
             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
-            || exprIsLiteralString rhs)
+            || exprIsTickedString rhs)
            (mkStrictMsg binder)
 
         -- Check that if the binder is at the top level and has type Addr#,
         -- that it is a string literal, see
         -- Note [CoreSyn top-level string literals].
        ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
-                 || exprIsLiteralString rhs)
+                 || exprIsTickedString rhs)
            (mkTopNonLitStrMsg binder)
 
        ; flags <- getLintFlags
@@ -548,6 +564,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
                                   (mkInvalidJoinPointMsg binder binder_ty)
 
        ; when (lf_check_inline_loop_breakers flags
+               && isStableUnfolding (realIdUnfolding binder)
                && isStrongLoopBreaker (idOccInfo binder)
                && isInlinePragma (idInlinePragma binder))
               (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
@@ -645,18 +662,11 @@ lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
     go _ = markAllJoinsBad $ lintCoreExpr rhs
 
 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
-lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
-  | isStableSource src
+lintIdUnfolding bndr bndr_ty uf
+  | isStableUnfolding uf
+  , Just rhs <- maybeUnfoldingTemplate uf
   = do { ty <- lintRhs bndr rhs
        ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
-
-lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs
-                                            , df_args = args })
-  = do { ty <- lintBinders LambdaBind bndrs $ \ bndrs' ->
-               do { res_ty <- lintCoreArgs (dataConRepType con) args
-                  ; return (mkLamTypes bndrs' res_ty) }
-       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) }
-
 lintIdUnfolding  _ _ _
   = return ()       -- Do not Lint unstable unfoldings, because that leads
                     -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
@@ -703,8 +713,7 @@ lintCoreExpr (Cast expr co)
   = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
        ; co' <- applySubstCo co
        ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
-       ; lintL (classifiesTypeWithValues k2)
-               (text "Target of cast not # or *:" <+> ppr co)
+       ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co))
        ; lintRole co' Representational r
        ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
        ; return to_ty }
@@ -787,13 +796,9 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
      ; (alt_ty, _) <- lintInTy alt_ty
      ; (var_ty, _) <- lintInTy (idType var)
 
-     -- See Note [No alternatives lint check]
-     ; when (null alts) $
-     do { checkL (not (exprIsHNF scrut))
-          (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut)
-        ; checkWarnL scrut_diverges
-          (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut)
-        }
+     -- We used to try to check whether a case expression with no
+     -- alternatives was legitimate, but this didn't work.
+     -- See Note [No alternatives lint check] for details.
 
      -- See Note [Rules for floating-point comparisons] in PrelRules
      ; let isLitPat (LitAlt _, _ , _) = True
@@ -842,6 +847,7 @@ lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
 lintVarOcc var nargs
   = do  { checkL (isNonCoVarId var)
                  (text "Non term variable" <+> ppr var)
+                 -- See CoreSyn Note [Variable occurrences in Core]
 
         -- Cneck that the type of the occurrence is the same
         -- as the type of the binding site
@@ -920,23 +926,46 @@ checkJoinOcc var n_args
 {-
 Note [No alternatives lint check]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Case expressions with no alternatives are odd beasts, and worth looking at
-in the linter (cf Trac #10180).  We check two things:
+Case expressions with no alternatives are odd beasts, and it would seem
+like they would worth be looking at in the linter (cf Trac #10180). We
+used to check two things:
 
-* exprIsHNF is false: certainly, it would be terribly wrong if the
-  scrutinee was already in head normal form.
+* exprIsHNF is false: it would *seem* to be terribly wrong if
+  the scrutinee was already in head normal form.
 
 * exprIsBottom is true: we should be able to see why GHC believes the
   scrutinee is diverging for sure.
 
-In principle, the first check is redundant: exprIsBottom == True will
-always imply exprIsHNF == False.  But the first check is reliable: If
-exprIsHNF == True, then there definitely is a problem (exprIsHNF errs
-on the right side).  If the second check triggers then it may be the
-case that the compiler got smarter elsewhere, and the empty case is
-correct, but that exprIsBottom is unable to see it. In particular, the
-empty-type check in exprIsBottom is an approximation. Therefore, this
-check is not fully reliable, and we keep both around.
+It was already known that the second test was not entirely reliable.
+Unfortunately (Trac #13990), the first test turned out not to be reliable
+either. Getting the checks right turns out to be somewhat complicated.
+
+For example, suppose we have (comment 8)
+
+  data T a where
+    TInt :: T Int
+
+  absurdTBool :: T Bool -> a
+  absurdTBool v = case v of
+
+  data Foo = Foo !(T Bool)
+
+  absurdFoo :: Foo -> a
+  absurdFoo (Foo x) = absurdTBool x
+
+GHC initially accepts the empty case because of the GADT conditions. But then
+we inline absurdTBool, getting
+
+  absurdFoo (Foo x) = case x of
+
+x is in normal form (because the Foo constructor is strict) but the
+case is empty. To avoid this problem, GHC would have to recognize
+that matching on Foo x is already absurd, which is not so easy.
+
+More generally, we don't really know all the ways that GHC can
+lose track of why an expression is bottom, so we shouldn't make too
+much fuss when that happens.
+
 
 Note [Beta redexes]
 ~~~~~~~~~~~~~~~~~~~
@@ -1092,7 +1121,7 @@ checkCaseAlts e ty alts =
   where
     (con_alts, maybe_deflt) = findDefault alts
 
-        -- Check that successive alternatives have increasing tags
+        -- Check that successive alternatives have strictly increasing tags
     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
     increasing_tag _                         = True
 
@@ -1244,6 +1273,19 @@ lintIdBndr top_lvl bind_site id linterF
 %************************************************************************
 -}
 
+lintTypes :: DynFlags
+          -> [TyCoVar]   -- Treat these as in scope
+          -> [Type]
+          -> Maybe MsgDoc -- Nothing => OK
+lintTypes dflags vars tys
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = emptyInScopeSet
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = lintBinders LambdaBind vars $ \_ ->
+             mapM_ lintInTy tys
+
 lintInTy :: InType -> LintM (LintedType, LintedKind)
 -- Types only, not kinds
 -- Check the type, and apply the substitution to it
@@ -1252,7 +1294,9 @@ lintInTy ty
   = addLoc (InType ty) $
     do  { ty' <- applySubstTy ty
         ; k  <- lintType ty'
-        ; lintKind k
+        ; lintKind k  -- The kind returned by lintType is already
+                      -- a LintedKind but we also want to check that
+                      -- k :: *, which lintKind does
         ; return (ty', k) }
 
 checkTyCon :: TyCon -> LintM ()
@@ -1280,25 +1324,25 @@ lintType ty@(AppTy t1 t2)
        ; lint_ty_app ty k1 [(t2,k2)] }
 
 lintType ty@(TyConApp tc tys)
-  | Just ty' <- coreView ty
-  = lintType ty'   -- Expand type synonyms, so that we do not bogusly complain
-                   --  about un-saturated type synonyms
+  | isTypeSynonymTyCon tc
+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags
+       ; lintTySynApp report_unsat ty tc tys }
 
-  -- We should never see a saturated application of funTyCon; such applications
-  -- should be represented with the FunTy constructor. See Note [Linting
-  -- function types] and Note [Representation of function types].
   | isFunTyCon tc
   , tys `lengthIs` 4
+    -- We should never see a saturated application of funTyCon; such
+    -- applications should be represented with the FunTy constructor.
+    -- See Note [Linting function types] and
+    -- Note [Representation of function types].
   = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
 
-  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
-       -- Also type synonyms and type families
+  | isTypeFamilyTyCon tc -- Check for unsaturated type family
   , tys `lengthLessThan` tyConArity tc
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
 
   | otherwise
   = do { checkTyCon tc
-       ; ks <- mapM lintType tys
+       ; ks <- setReportUnsat True (mapM lintType tys)
        ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
 
 -- arrows can related *unlifted* kinds, so this has to be separate from
@@ -1308,28 +1352,83 @@ lintType ty@(FunTy t1 t2)
        ; k2 <- lintType t2
        ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
 
-lintType t@(ForAllTy (TvBndr tv _vis) ty)
-  = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t)
-       ; lintTyBndr tv $ \tv' ->
-          do { k <- lintType ty
-             ; lintL (not (tv' `elemVarSet` tyCoVarsOfType k))
-                     (text "Variable escape in forall:" <+> ppr t)
-             ; lintL (classifiesTypeWithValues k)
-                     (text "Non-* and non-# kind in forall:" <+> ppr t)
-             ; return k }}
+lintType t@(ForAllTy (Bndr tv _vis) ty)
+  -- forall over types
+  | isTyVar tv
+  = do { lintTyBndr tv $ \tv' ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; case occCheckExpand [tv'] k of  -- See Note [Stupid type synonyms]
+           Just k' -> return k'
+           Nothing -> failWithL (hang (text "Variable escape in forall:")
+                                    2 (vcat [ text "type:" <+> ppr t
+                                            , text "kind:" <+> ppr k ]))
+    }}
+
+lintType t@(ForAllTy (Bndr cv _vis) ty)
+  -- forall over coercions
+  = do { lintL (isCoVar cv)
+               (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t)
+       ; lintL (cv `elemVarSet` tyCoVarsOfType ty)
+               (text "Covar does not occur in the body:" <+> ppr t)
+       ; lintCoBndr cv $ \_ ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; return liftedTypeKind
+           -- We don't check variable escape here. Namely, k could refer to cv'
+           -- See Note [NthCo and newtypes] in TyCoRep
+    }}
 
 lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
 
 lintType (CastTy ty co)
   = do { k1 <- lintType ty
        ; (k1', k2) <- lintStarCoercion co
-       ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1)
+       ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1)
        ; return k2 }
 
 lintType (CoercionTy co)
   = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
        ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
 
+{- Note [Stupid type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14939)
+   type Alg cls ob = ob
+   f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b
+
+Here 'cls' appears free in b's kind, which would usually be illegal
+(because in (forall a. ty), ty's kind should not mention 'a'). But
+#in this case (Alg cls *) = *, so all is well.  Currently we allow
+this, and make Lint expand synonyms where necessary to make it so.
+
+c.f. TcUnify.occCheckExpand and CoreUtils.coreAltsType which deal
+with the same problem. A single systematic solution eludes me.
+-}
+
+-----------------
+lintTySynApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind
+-- See Note [Linting type synonym applications]
+lintTySynApp report_unsat ty tc tys
+  | report_unsat   -- Report unsaturated only if report_unsat is on
+  , tys `lengthLessThan` tyConArity tc
+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
+
+  | otherwise
+  = do { ks <- setReportUnsat False (mapM lintType tys)
+
+       ; when report_unsat $
+         case expandSynTyCon_maybe tc tys of
+            Nothing -> pprPanic "lintTySynApp" (ppr tc <+> ppr tys)
+                       -- Previous guards should have made this impossible
+            Just (tenv, rhs, tys') -> do { _ <- lintType expanded_ty
+                                         ; return () }
+                where
+                  expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
+
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-----------------
 lintKind :: OutKind -> LintM ()
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -1338,13 +1437,15 @@ lintKind k = do { sk <- lintType k
                          (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
                                       2 (text "has kind:" <+> ppr sk))) }
 
--- confirms that a type is really *
-lintStar :: SDoc -> OutKind -> LintM ()
-lintStar doc k
+-----------------
+-- Confirms that a type is really *, #, Constraint etc
+checkValueKind :: OutKind -> SDoc -> LintM ()
+checkValueKind k doc
   = lintL (classifiesTypeWithValues k)
           (text "Non-*-like kind when *-like expected:" <+> ppr k $$
            text "when checking" <+> doc)
 
+-----------------
 lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -1359,6 +1460,7 @@ lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2
                   2 (text "in" <+> what)
              , what <+> text "kind:" <+> ppr k ]
 
+-----------------
 lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
 lint_ty_app ty k tys
   = lint_app (text "type" <+> quotes (ppr ty)) k tys
@@ -1390,23 +1492,28 @@ lint_app doc kfn kas
          -- Note [The substitution invariant] in TyCoRep
          ; foldlM (go_app in_scope) kfn kas }
   where
-    fail_msg = vcat [ hang (text "Kind application error in") 2 doc
-                    , nest 2 (text "Function kind =" <+> ppr kfn)
-                    , nest 2 (text "Arg kinds =" <+> ppr kas) ]
+    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
+                          , nest 2 (text "Function kind =" <+> ppr kfn)
+                          , nest 2 (text "Arg kinds =" <+> ppr kas)
+                          , extra ]
 
-    go_app in_scope kfn ka
+    go_app in_scope kfn tka
       | Just kfn' <- coreView kfn
-      = go_app in_scope kfn' ka
+      = go_app in_scope kfn' tka
 
-    go_app _ (FunTy kfa kfb) (_,ka)
-      = do { unless (ka `eqType` kfa) (addErrL fail_msg)
+    go_app _ (FunTy kfa kfb) tka@(_,ka)
+      = do { unless (ka `eqType` kfa) $
+             addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
            ; return kfb }
 
-    go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka)
-      = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg)
-           ; return (substTyWithInScope in_scope [kv] [ta] kfn) }
+    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka)
+      = do { let kv_kind = varType kv
+           ; unless (ka `eqType` kv_kind) $
+             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka)))
+           ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn }
 
-    go_app _ _ _ = failWithL fail_msg
+    go_app _ kfn ka
+       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka)))
 
 {- *********************************************************************
 *                                                                      *
@@ -1421,7 +1528,7 @@ lintCoreRule _ _ (BuiltinRule {})
 lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
                                    , ru_args = args, ru_rhs = rhs })
   = lintBinders LambdaBind bndrs $ \ _ ->
-    do { lhs_ty <- foldM lintCoreArg fun_ty args
+    do { lhs_ty <- lintCoreArgs fun_ty args
        ; rhs_ty <- case isJoinId_maybe fun of
                      Just join_arity
                        -> do { checkL (args `lengthIs` join_arity) $
@@ -1431,7 +1538,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
                      _ -> markAllJoinsBad $ lintCoreExpr rhs
        ; ensureEqTys lhs_ty rhs_ty $
          (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
-                            , text "rhs type:" <+> ppr rhs_ty ])
+                            , text "rhs type:" <+> ppr rhs_ty
+                            , text "fun_ty:" <+> ppr fun_ty ])
        ; let bad_bndrs = filter is_bad_bndr bndrs
 
        ; checkL (null bad_bndrs)
@@ -1519,8 +1627,8 @@ lintInCo co
 lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
 lintStarCoercion g
   = do { (k1, k2, t1, t2, r) <- lintCoercion g
-       ; lintStar (text "the kind of the left type in" <+> ppr g) k1
-       ; lintStar (text "the kind of the right type in" <+> ppr g) k2
+       ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g)
+       ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g)
        ; lintRole g Nominal r
        ; return (t1, t2) }
 
@@ -1530,15 +1638,28 @@ lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, Linted
 --
 -- If   lintCoercion co = (k1, k2, s1, s2, r)
 -- then co :: s1 ~r s2
---      s1 :: k2
+--      s1 :: k1
 --      s2 :: k2
 
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-lintCoercion (Refl r ty)
+lintCoercion (Refl ty)
+  = do { k <- lintType ty
+       ; return (k, k, ty, ty, Nominal) }
+
+lintCoercion (GRefl r ty MRefl)
   = do { k <- lintType ty
        ; return (k, k, ty, ty, r) }
 
+lintCoercion (GRefl r ty (MCo co))
+  = do { k <- lintType ty
+       ; (_, _, k1, k2, r') <- lintCoercion co
+       ; ensureEqTys k k1
+               (hang (text "GRefl coercion kind mis-match:" <+> ppr co)
+                   2 (vcat [ppr ty, ppr k, ppr k1]))
+       ; lintRole co Nominal r'
+       ; return (k1, k2, ty, mkCastTy ty co, r) }
+
 lintCoercion co@(TyConAppCo r tc cos)
   | tc `hasKey` funTyConKey
   , [_rep1,_rep2,_co1,_co2] <- cos
@@ -1559,7 +1680,7 @@ lintCoercion co@(TyConAppCo r tc cos)
 lintCoercion co@(AppCo co1 co2)
   | TyConAppCo {} <- co1
   = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
-  | Refl _ (TyConApp {}) <- co1
+  | Just (TyConApp {}, _) <- isReflCo_maybe co1
   = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
   | otherwise
   = do { (k1,  k2,  s1, s2, r1) <- lintCoercion co1
@@ -1575,6 +1696,8 @@ lintCoercion co@(AppCo co1 co2)
 
 ----------
 lintCoercion (ForAllCo tv1 kind_co co)
+  -- forall over types
+  | isTyVar tv1
   = do { (_, k2) <- lintStarCoercion kind_co
        ; let tv2 = setTyVarKind tv1 k2
        ; addInScopeVar tv1 $
@@ -1594,6 +1717,37 @@ lintCoercion (ForAllCo tv1 kind_co co)
                    substTy subst t2
        ; return (k3, k4, tyl, tyr, r) } }
 
+lintCoercion (ForAllCo cv1 kind_co co)
+  -- forall over coercions
+  = ASSERT( isCoVar cv1 )
+    do { (_, k2) <- lintStarCoercion kind_co
+       ; let cv2 = setVarType cv1 k2
+       ; addInScopeVar cv1 $
+    do {
+       ; (k3, k4, t1, t2, r) <- lintCoercion co
+       ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co)
+       ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co)
+           -- See Note [Weird typing rule for ForAllTy] in Type
+       ; in_scope <- getInScope
+       ; let tyl   = mkTyCoInvForAllTy cv1 t1
+             r2    = coVarRole cv1
+             kind_co' = downgradeRole r2 Nominal kind_co
+             eta1  = mkNthCo r2 2 kind_co'
+             eta2  = mkNthCo r2 3 kind_co'
+             subst = mkCvSubst in_scope $
+                     -- We need both the free vars of the `t2` and the
+                     -- free vars of the range of the substitution in
+                     -- scope. All the free vars of `t2` and `kind_co` should
+                     -- already be in `in_scope`, because they've been
+                     -- linted and `cv2` has the same unique as `cv1`.
+                     -- See Note [The substitution invariant]
+                     unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2)
+                                          `mkTransCo` (mkSymCo eta2))
+             tyr = mkTyCoInvForAllTy cv2 $
+                   substTy subst t2
+       ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } }
+                   -- See Note [Weird typing rule for ForAllTy] in Type
+
 lintCoercion co@(FunCo r co1 co2)
   = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
        ; (k2,k'2,s2,t2,r2) <- lintCoercion co2
@@ -1630,8 +1784,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
                                     ; check_kinds kco k1 k2 }
 
            PluginProv _     -> return ()  -- no extra checks
-           HoleProv h       -> addErrL $
-                               text "Unfilled coercion hole:" <+> ppr h
 
        ; when (r /= Phantom && classifiesTypeWithValues k1
                             && classifiesTypeWithValues k2)
@@ -1668,8 +1820,8 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
        = do { dflags <- getDynFlags
             ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
                          (report "between unboxed and boxed value")
-            ; checkWarnL (TyCon.primRepSizeW dflags rep1
-                           == TyCon.primRepSizeW dflags rep2)
+            ; checkWarnL (TyCon.primRepSizeB dflags rep1
+                           == TyCon.primRepSizeB dflags rep2)
                          (report "between unboxed values of different size")
             ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
                                    (TyCon.primRepIsFloat rep2)
@@ -1697,15 +1849,19 @@ lintCoercion co@(TransCo co1 co2)
        ; lintRole co r1 r2
        ; return (k1a, k2b, ty1a, ty2b, r1) }
 
-lintCoercion the_co@(NthCo n co)
+lintCoercion the_co@(NthCo r0 n co)
   = do { (_, _, s, t, r) <- lintCoercion co
        ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
-         { (Just (tv_s, _ty_s), Just (tv_t, _ty_t))
-             |  n == 0
-             -> return (ks, kt, ts, tt, Nominal)
+         { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t))
+             -- works for both tyvar and covar
+             | n == 0
+             ,  (isForAllTy_ty s && isForAllTy_ty t)
+             || (isForAllTy_co s && isForAllTy_co t)
+             -> do { lintRole the_co Nominal r0
+                   ; return (ks, kt, ts, tt, r0) }
              where
-               ts = tyVarKind tv_s
-               tt = tyVarKind tv_t
+               ts = varType tcv_s
+               tt = varType tcv_t
                ks = typeKind ts
                kt = typeKind tt
 
@@ -1716,7 +1872,8 @@ lintCoercion the_co@(NthCo n co)
                  -- see Note [NthCo and newtypes] in TyCoRep
              , tys_s `equalLength` tys_t
              , tys_s `lengthExceeds` n
-             -> return (ks, kt, ts, tt, tr)
+             -> do { lintRole the_co tr r0
+                   ; return (ks, kt, ts, tt, r0) }
              where
                ts = getNth tys_s n
                tt = getNth tys_t n
@@ -1747,16 +1904,32 @@ lintCoercion (InstCo co arg)
        ; (k1',k2',s1,s2, r') <- lintCoercion arg
        ; lintRole arg Nominal r'
        ; in_scope <- getInScope
-       ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of
-          (Just (tv1,t1), Just (tv2,t2))
-            | k1' `eqType` tyVarKind tv1
-            , k2' `eqType` tyVarKind tv2
-            -> return (k3, k4,
-                       substTyWithInScope in_scope [tv1] [s1] t1,
-                       substTyWithInScope in_scope [tv2] [s2] t2, r)
-            | otherwise
-            -> failWithL (text "Kind mis-match in inst coercion")
-          _ -> failWithL (text "Bad argument of inst") }
+       ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of
+         -- forall over tvar
+         { (Just (tv1,t1), Just (tv2,t2))
+             | k1' `eqType` tyVarKind tv1
+             , k2' `eqType` tyVarKind tv2
+             -> return (k3, k4,
+                        substTyWithInScope in_scope [tv1] [s1] t1,
+                        substTyWithInScope in_scope [tv2] [s2] t2, r)
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of
+         -- forall over covar
+         { (Just (cv1, t1), Just (cv2, t2))
+             | k1' `eqType` varType cv1
+             , k2' `eqType` varType cv2
+             , CoercionTy s1' <- s1
+             , CoercionTy s2' <- s2
+             -> do { return $
+                       (liftedTypeKind, liftedTypeKind
+                          -- See Note [Weird typing rule for ForAllTy] in Type
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2
+                       , r) }
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> failWithL (text "Bad argument of inst") }}}
 
 lintCoercion co@(AxiomInstCo con ind cos)
   = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
@@ -1797,12 +1970,6 @@ lintCoercion co@(AxiomInstCo con ind cos)
            ; return (extendTCvSubst subst_l ktv s',
                      extendTCvSubst subst_r ktv t') }
 
-lintCoercion (CoherenceCo co1 co2)
-  = do { (_, k2, t1, t2, r) <- lintCoercion co1
-       ; let lhsty = mkCastTy t1 co2
-       ; k1' <- lintType lhsty
-       ; return (k1', k2, lhsty, t2, r) }
-
 lintCoercion (KindCo co)
   = do { (k1, k2, _, _, _) <- lintCoercion co
        ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
@@ -1838,6 +2005,11 @@ lintCoercion this@(AxiomRuleCo co cs)
                           [ text "Expected:" <+> int (n + length es)
                           , text "Provided:" <+> int n ]
 
+lintCoercion (HoleCo h)
+  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h
+       ; lintCoercion (CoVarCo (coHoleCoVar h)) }
+
+
 ----------
 lintUnliftedCoVar :: CoVar -> LintM ()
 lintUnliftedCoVar cv
@@ -1870,8 +2042,8 @@ data LintEnv
 data LintFlags
   = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
        , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
-       , lf_check_static_ptrs          :: StaticPtrCheck
-                                             -- ^ See Note [Checking StaticPtrs]
+       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]
+       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]
     }
 
 -- See Note [Checking StaticPtrs]
@@ -1888,6 +2060,7 @@ defaultLintFlags :: LintFlags
 defaultLintFlags = LF { lf_check_global_ids = False
                       , lf_check_inline_loop_breakers = True
                       , lf_check_static_ptrs = AllowAnywhere
+                      , lf_report_unsat_syns = True
                       }
 
 newtype LintM a =
@@ -1932,6 +2105,37 @@ rename type binders as we go, maintaining a substitution.
 The same substitution also supports let-type, current expressed as
         (/\(a:*). body) ty
 Here we substitute 'ty' for 'a' in 'body', on the fly.
+
+Note [Linting type synonym applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When lining a type-synonym application
+  S ty1 .. tyn
+we behave as follows (Trac #15057):
+
+* If lf_report_unsat_syns = True, and S has arity < n,
+  complain about an unsaturated type synonym.
+
+* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.
+
+  Reason: catch out of scope variables or other ill-kinded gubbins,
+  even if S discards that argument entirely. E.g. (#15012):
+     type FakeOut a = Int
+     type family TF a
+     type instance TF Int = FakeOut a
+  Here 'a' is out of scope; but if we expand FakeOut, we conceal
+  that out-of-scope error.
+
+  Reason for switching off lf_report_unsat_syns: with
+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they
+  are saturated when the type is expanded. Example
+     type T f = f Int
+     type S a = a -> a
+     type Z = T S
+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.
+
+* If lf_report_unsat_syns is on, expand the synonym application and
+  lint the result.  Reason: want to check that synonyms are saturated
+  when the type is expanded.
 -}
 
 instance Functor LintM where
@@ -1942,17 +2146,15 @@ instance Applicative LintM where
       (<*>) = ap
 
 instance Monad LintM where
-  fail err = failWithL (text err)
+  fail = MonadFail.fail
   m >>= k  = LintM (\ env errs ->
                        let (res, errs') = unLintM m env errs in
                          case res of
                            Just r -> unLintM (k r) env errs'
                            Nothing -> (Nothing, errs'))
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail LintM where
     fail err = failWithL (text err)
-#endif
 
 instance HasDynFlags LintM where
   getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
@@ -1982,6 +2184,13 @@ initL dflags flags in_scope m
              , le_loc = []
              , le_dynflags = dflags }
 
+setReportUnsat :: Bool -> LintM a -> LintM a
+-- Switch off lf_report_unsat_syns
+setReportUnsat ru thing_inside
+  = LintM $ \ env errs ->
+    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }
+    in unLintM thing_inside env' errs
+
 getLintFlags :: LintM LintFlags
 getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
 
@@ -2017,10 +2226,9 @@ addMsg env msgs msg
    locs = le_loc env
    (loc, cxt1) = dumpLoc (head locs)
    cxts        = [snd (dumpLoc loc) | loc <- locs]
-   context     = sdocWithPprDebug $ \dbg -> if dbg
-                  then vcat (reverse cxts) $$ cxt1 $$
-                         text "Substitution:" <+> ppr (le_subst env)
-                  else cxt1
+   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$
+                             text "Substitution:" <+> ppr (le_subst env))
+                            cxt1
 
    mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
 
@@ -2342,14 +2550,32 @@ mkArityMsg binder
          ]
            where (StrictSig dmd_ty) = idStrictness binder
 -}
-mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc
-mkCastErr expr co from_ty expr_ty
-  = vcat [text "From-type of Cast differs from type of enclosed expression",
-          text "From-type:" <+> ppr from_ty,
-          text "Type of enclosed expr:" <+> ppr expr_ty,
-          text "Actual enclosed expr:" <+> ppr expr,
+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
+
+mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc
+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)
+
+mk_cast_err :: String -- ^ What sort of casted thing this is
+                      --   (\"expression\" or \"type\").
+            -> String -- ^ What sort of coercion is being used
+                      --   (\"type\" or \"kind\").
+            -> SDoc   -- ^ The thing being casted.
+            -> Coercion -> Type -> Type -> MsgDoc
+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty
+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg
+            <+> text "of" <+> enclosed_msg,
+          from_msg <> colon <+> ppr from_ty,
+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon
+            <+> ppr thing_ty,
+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,
           text "Coercion used in cast:" <+> ppr co
          ]
+  where
+    co_msg, from_msg, enclosed_msg :: SDoc
+    co_msg       = text co_str
+    from_msg     = text "From-" <> co_msg
+    enclosed_msg = text "enclosed" <+> text thing_str
 
 mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
 mkBadUnivCoMsg lr co
@@ -2431,15 +2657,15 @@ pprLeftOrRight :: LeftOrRight -> MsgDoc
 pprLeftOrRight CLeft  = text "left"
 pprLeftOrRight CRight = text "right"
 
-dupVars :: [[Var]] -> MsgDoc
+dupVars :: [NonEmpty Var] -> MsgDoc
 dupVars vars
   = hang (text "Duplicate variables brought into scope")
-       2 (ppr vars)
+       2 (ppr (map toList vars))
 
-dupExtVars :: [[Name]] -> MsgDoc
+dupExtVars :: [NonEmpty Name] -> MsgDoc
 dupExtVars vars
   = hang (text "Duplicate top-level variables with the same qualified name")
-       2 (ppr vars)
+       2 (ppr (map toList vars))
 
 {-
 ************************************************************************
diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/CoreMap.hs
index a6b9db46cb..11f2fb1b11 100644
--- a/compiler/coreSyn/TrieMap.hs
+++ b/compiler/coreSyn/CoreMap.hs
@@ -9,7 +9,7 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
-module TrieMap(
+module CoreMap(
    -- * Maps over Core expressions
    CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
    -- * Maps over 'Type's
@@ -24,6 +24,8 @@ module TrieMap(
    ListMap,
    -- * Maps over 'Literal's
    LiteralMap,
+   -- * Map for compressing leaves. See Note [Compressed TrieMap]
+   GenMap,
    -- * 'TrieMap' class
    TrieMap(..), insertTM, deleteTM,
    lkDFreeVar, xtDFreeVar,
@@ -31,15 +33,15 @@ module TrieMap(
    (>.>), (|>), (|>>),
  ) where
 
+import GhcPrelude
+
+import TrieMap
 import CoreSyn
 import Coercion
-import Literal
 import Name
 import Type
 import TyCoRep
 import Var
-import UniqDFM
-import Unique( Unique )
 import FastString(FastString)
 import Util
 
@@ -51,386 +53,44 @@ import Outputable
 import Control.Monad( (>=>) )
 
 {-
-This module implements TrieMaps, which are finite mappings
-whose key is a structured value like a CoreExpr or Type.
+This module implements TrieMaps over Core related data structures
+like CoreExpr or Type. It is built on the Tries from the TrieMap
+module.
 
 The code is very regular and boilerplate-like, but there is
 some neat handling of *binders*.  In effect they are deBruijn
 numbered on the fly.
 
-The regular pattern for handling TrieMaps on data structures was first
-described (to my knowledge) in Connelly and Morris's 1995 paper "A
-generalization of the Trie Data Structure"; there is also an accessible
-description of the idea in Okasaki's book "Purely Functional Data
-Structures", Section 10.3.2
 
-************************************************************************
-*                                                                      *
-                   The TrieMap class
-*                                                                      *
-************************************************************************
 -}
 
-type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)
-                                --               or an existing elt (Just)
-
-class TrieMap m where
-   type Key m :: *
-   emptyTM  :: m a
-   lookupTM :: forall b. Key m -> m b -> Maybe b
-   alterTM  :: forall b. Key m -> XT b -> m b -> m b
-   mapTM    :: (a->b) -> m a -> m b
-
-   foldTM   :: (a -> b -> b) -> m a -> b -> b
-      -- The unusual argument order here makes
-      -- it easy to compose calls to foldTM;
-      -- see for example fdE below
-
-insertTM :: TrieMap m => Key m -> a -> m a -> m a
-insertTM k v m = alterTM k (\_ -> Just v) m
-
-deleteTM :: TrieMap m => Key m -> m a -> m a
-deleteTM k m = alterTM k (\_ -> Nothing) m
-
 ----------------------
 -- Recall that
 --   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
 
-(>.>) :: (a -> b) -> (b -> c) -> a -> c
--- Reverse function composition (do f first, then g)
-infixr 1 >.>
-(f >.> g) x = g (f x)
-infixr 1 |>, |>>
-
-(|>) :: a -> (a->b) -> b     -- Reverse application
-x |> f = f x
-
-----------------------
-(|>>) :: TrieMap m2
-      => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a))
-      -> (m2 a -> m2 a)
-      -> m1 (m2 a) -> m1 (m2 a)
-(|>>) f g = f (Just . g . deMaybe)
-
-deMaybe :: TrieMap m => Maybe (m a) -> m a
-deMaybe Nothing  = emptyTM
-deMaybe (Just m) = m
-
-{-
-************************************************************************
-*                                                                      *
-                   IntMaps
-*                                                                      *
-************************************************************************
--}
-
-instance TrieMap IntMap.IntMap where
-  type Key IntMap.IntMap = Int
-  emptyTM = IntMap.empty
-  lookupTM k m = IntMap.lookup k m
-  alterTM = xtInt
-  foldTM k m z = IntMap.foldr k z m
-  mapTM f m = IntMap.map f m
-
-xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
-xtInt k f m = IntMap.alter f k m
-
-instance Ord k => TrieMap (Map.Map k) where
-  type Key (Map.Map k) = k
-  emptyTM = Map.empty
-  lookupTM = Map.lookup
-  alterTM k f m = Map.alter f k m
-  foldTM k m z = Map.foldr k z m
-  mapTM f m = Map.map f m
-
-
-{-
-Note [foldTM determinism]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We want foldTM to be deterministic, which is why we have an instance of
-TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that
-go wrong if foldTM is nondeterministic. Consider:
-
-  f a b = return (a <> b)
-
-Depending on the order that the typechecker generates constraints you
-get either:
-
-  f :: (Monad m, Monoid a) => a -> a -> m a
-
-or:
-
-  f :: (Monoid a, Monad m) => a -> a -> m a
-
-The generated code will be different after desugaring as the dictionaries
-will be bound in different orders, leading to potential ABI incompatibility.
-
-One way to solve this would be to notice that the typeclasses could be
-sorted alphabetically.
-
-Unfortunately that doesn't quite work with this example:
-
-  f a b = let x = a <> a; y = b <> b in x
-
-where you infer:
-
-  f :: (Monoid m, Monoid m1) => m1 -> m -> m1
-
-or:
-
-  f :: (Monoid m1, Monoid m) => m1 -> m -> m1
-
-Here you could decide to take the order of the type variables in the type
-according to depth first traversal and use it to order the constraints.
-
-The real trouble starts when the user enables incoherent instances and
-the compiler has to make an arbitrary choice. Consider:
-
-  class T a b where
-    go :: a -> b -> String
-
-  instance (Show b) => T Int b where
-    go a b = show a ++ show b
-
-  instance (Show a) => T a Bool where
-    go a b = show a ++ show b
-
-  f = go 10 True
-
-GHC is free to choose either dictionary to implement f, but for the sake of
-determinism we'd like it to be consistent when compiling the same sources
-with the same flags.
-
-inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it
-gets converted to a bag of (Wanted) Cts using a fold. Then in
-solve_simple_wanteds it's merged with other WantedConstraints. We want the
-conversion to a bag to be deterministic. For that purpose we use UniqDFM
-instead of UniqFM to implement the TrieMap.
-
-See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made
-deterministic.
--}
-
-instance TrieMap UniqDFM where
-  type Key UniqDFM = Unique
-  emptyTM = emptyUDFM
-  lookupTM k m = lookupUDFM m k
-  alterTM k f m = alterUDFM f m k
-  foldTM k m z = foldUDFM k z m
-  mapTM f m = mapUDFM f m
-
-{-
-************************************************************************
-*                                                                      *
-                   Maybes
-*                                                                      *
-************************************************************************
-
-If              m is a map from k -> val
-then (MaybeMap m) is a map from (Maybe k) -> val
--}
-
-data MaybeMap m a = MM { mm_nothing  :: Maybe a, mm_just :: m a }
-
-instance TrieMap m => TrieMap (MaybeMap m) where
-   type Key (MaybeMap m) = Maybe (Key m)
-   emptyTM  = MM { mm_nothing = Nothing, mm_just = emptyTM }
-   lookupTM = lkMaybe lookupTM
-   alterTM  = xtMaybe alterTM
-   foldTM   = fdMaybe
-   mapTM    = mapMb
-
-mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
-mapMb f (MM { mm_nothing = mn, mm_just = mj })
-  = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
-
-lkMaybe :: (forall b. k -> m b -> Maybe b)
-        -> Maybe k -> MaybeMap m a -> Maybe a
-lkMaybe _  Nothing  = mm_nothing
-lkMaybe lk (Just x) = mm_just >.> lk x
-
-xtMaybe :: (forall b. k -> XT b -> m b -> m b)
-        -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a
-xtMaybe _  Nothing  f m = m { mm_nothing  = f (mm_nothing m) }
-xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f }
-
-fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b
-fdMaybe k m = foldMaybe k (mm_nothing m)
-            . foldTM k (mm_just m)
-
-{-
-************************************************************************
-*                                                                      *
-                   Lists
-*                                                                      *
-************************************************************************
--}
-
-data ListMap m a
-  = LM { lm_nil  :: Maybe a
-       , lm_cons :: m (ListMap m a) }
-
-instance TrieMap m => TrieMap (ListMap m) where
-   type Key (ListMap m) = [Key m]
-   emptyTM  = LM { lm_nil = Nothing, lm_cons = emptyTM }
-   lookupTM = lkList lookupTM
-   alterTM  = xtList alterTM
-   foldTM   = fdList
-   mapTM    = mapList
-
-mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
-mapList f (LM { lm_nil = mnil, lm_cons = mcons })
-  = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
-
-lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
-        -> [k] -> ListMap m a -> Maybe a
-lkList _  []     = lm_nil
-lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs
-
-xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b)
-        -> [k] -> XT a -> ListMap m a -> ListMap m a
-xtList _  []     f m = m { lm_nil  = f (lm_nil m) }
-xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f }
-
-fdList :: forall m a b. TrieMap m
-       => (a -> b -> b) -> ListMap m a -> b -> b
-fdList k m = foldMaybe k          (lm_nil m)
-           . foldTM    (fdList k) (lm_cons m)
-
-foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
-foldMaybe _ Nothing  b = b
-foldMaybe k (Just a) b = k a b
-
-{-
-************************************************************************
-*                                                                      *
-                   Basic maps
-*                                                                      *
-************************************************************************
--}
-
-lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
-lkDNamed n env = lookupDNameEnv env (getName n)
-
-xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a
-xtDNamed tc f m = alterDNameEnv f m (getName tc)
-
-------------------------
-type LiteralMap  a = Map.Map Literal a
-
-emptyLiteralMap :: LiteralMap a
-emptyLiteralMap = emptyTM
-
-lkLit :: Literal -> LiteralMap a -> Maybe a
-lkLit = lookupTM
-
-xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a
-xtLit = alterTM
-
-{-
-************************************************************************
-*                                                                      *
-                   GenMap
-*                                                                      *
-************************************************************************
-
-Note [Compressed TrieMap]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The GenMap constructor augments TrieMaps with leaf compression.  This helps
-solve the performance problem detailed in #9960: suppose we have a handful
-H of entries in a TrieMap, each with a very large key, size K. If you fold over
-such a TrieMap you'd expect time O(H). That would certainly be true of an
-association list! But with TrieMap we actually have to navigate down a long
-singleton structure to get to the elements, so it takes time O(K*H).  This
-can really hurt on many type-level computation benchmarks:
-see for example T9872d.
-
-The point of a TrieMap is that you need to navigate to the point where only one
-key remains, and then things should be fast.  So the point of a SingletonMap
-is that, once we are down to a single (key,value) pair, we stop and
-just use SingletonMap.
-
-'EmptyMap' provides an even more basic (but essential) optimization: if there is
-nothing in the map, don't bother building out the (possibly infinite) recursive
-TrieMap structure!
--}
-
-data GenMap m a
-   = EmptyMap
-   | SingletonMap (Key m) a
-   | MultiMap (m a)
-
-instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where
-  ppr EmptyMap = text "Empty map"
-  ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v
-  ppr (MultiMap m) = ppr m
-
--- TODO undecidable instance
-instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
-   type Key (GenMap m) = Key m
-   emptyTM  = EmptyMap
-   lookupTM = lkG
-   alterTM  = xtG
-   foldTM   = fdG
-   mapTM    = mapG
-
 -- NB: Be careful about RULES and type families (#5821).  So we should make sure
 -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)
 
+-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not
+-- known when defining GenMap so we can only specialize them here.
+
 {-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}
 {-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}
 {-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}
-lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a
-lkG _ EmptyMap                         = Nothing
-lkG k (SingletonMap k' v') | k == k'   = Just v'
-                           | otherwise = Nothing
-lkG k (MultiMap m)                     = lookupTM k m
+
 
 {-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}
 {-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}
 {-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}
-xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a
-xtG k f EmptyMap
-    = case f Nothing of
-        Just v  -> SingletonMap k v
-        Nothing -> EmptyMap
-xtG k f m@(SingletonMap k' v')
-    | k' == k
-    -- The new key matches the (single) key already in the tree.  Hence,
-    -- apply @f@ to @Just v'@ and build a singleton or empty map depending
-    -- on the 'Just'/'Nothing' response respectively.
-    = case f (Just v') of
-        Just v'' -> SingletonMap k' v''
-        Nothing  -> EmptyMap
-    | otherwise
-    -- We've hit a singleton tree for a different key than the one we are
-    -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then
-    -- we can just return the old map. If not, we need a map with *two*
-    -- entries. The easiest way to do that is to insert two items into an empty
-    -- map of type @m a@.
-    = case f Nothing of
-        Nothing  -> m
-        Just v   -> emptyTM |> alterTM k' (const (Just v'))
-                           >.> alterTM k  (const (Just v))
-                           >.> MultiMap
-xtG k f (MultiMap m) = MultiMap (alterTM k f m)
 
 {-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}
 {-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}
 {-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}
-mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b
-mapG _ EmptyMap = EmptyMap
-mapG f (SingletonMap k v) = SingletonMap k (f v)
-mapG f (MultiMap m) = MultiMap (mapTM f m)
 
 {-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}
 {-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}
 {-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}
-fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
-fdG _ EmptyMap = \z -> z
-fdG k (SingletonMap _ v) = \z -> k v z
-fdG k (MultiMap m) = foldTM k m
+
 
 {-
 ************************************************************************
@@ -438,7 +98,16 @@ fdG k (MultiMap m) = foldTM k m
                    CoreMap
 *                                                                      *
 ************************************************************************
+-}
+
+lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
+lkDNamed n env = lookupDNameEnv env (getName n)
 
+xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a
+xtDNamed tc f m = alterDNameEnv f m (getName tc)
+
+
+{-
 Note [Binders]
 ~~~~~~~~~~~~~~
  * In general we check binders as late as possible because types are
@@ -545,7 +214,7 @@ instance Eq (DeBruijn CoreExpr) where
     go _ _ = False
 
 emptyE :: CoreMapX a
-emptyE = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap
+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
             , cm_co = emptyTM, cm_type = emptyTM
             , cm_cast = emptyTM, cm_app = emptyTM
             , cm_lam = emptyTM, cm_letn = emptyTM
@@ -612,7 +281,7 @@ lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a
 lkE (D env expr) cm = go expr cm
   where
     go (Var v)              = cm_var  >.> lkVar env v
-    go (Lit l)              = cm_lit  >.> lkLit l
+    go (Lit l)              = cm_lit  >.> lookupTM l
     go (Type t)             = cm_type >.> lkG (D env t)
     go (Coercion c)         = cm_co   >.> lkG (D env c)
     go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)
@@ -640,7 +309,7 @@ xtE (D env (Type t))             f m = m { cm_type = cm_type m
                                                  |> xtG (D env t) f }
 xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m
                                                  |> xtG (D env c) f }
-xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> xtLit l f }
+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }
 xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)
                                                  |>> xtG (D env c) f }
 xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)
@@ -687,7 +356,7 @@ instance TrieMap AltMap where
    type Key AltMap = CoreAlt
    emptyTM  = AM { am_deflt = emptyTM
                  , am_data = emptyDNameEnv
-                 , am_lit  = emptyLiteralMap }
+                 , am_lit  = emptyTM }
    lookupTM = lkA emptyCME
    alterTM  = xtA emptyCME
    foldTM   = fdA
@@ -712,7 +381,7 @@ mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
 
 lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
 lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)
-lkA env (LitAlt lit, _, rhs)  = am_lit >.> lkLit lit >=> lkG (D env rhs)
+lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)
 lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc
                                         >=> lkG (D (extendCMEs env bs) rhs)
 
@@ -720,7 +389,7 @@ xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a
 xtA env (DEFAULT, _, rhs)    f m =
     m { am_deflt = am_deflt m |> xtG (D env rhs) f }
 xtA env (LitAlt l, _, rhs)   f m =
-    m { am_lit   = am_lit m   |> xtLit l |>> xtG (D env rhs) f }
+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }
 xtA env (DataAlt d, bs, rhs) f m =
     m { am_data  = am_data m  |> xtDNamed d
                              |>> xtG (D (extendCMEs env bs) rhs) f }
@@ -814,7 +483,7 @@ trieMapView ty
   -- First check for TyConApps that need to be expanded to
   -- AppTy chains.
   | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty
-  = Just $ foldl AppTy (TyConApp tc []) tys
+  = Just $ foldl' AppTy (TyConApp tc []) tys
 
   -- Then resolve any remaining nullary synonyms.
   | Just ty' <- tcView ty = Just ty'
@@ -853,8 +522,8 @@ instance Eq (DeBruijn Type) where
             -> tc == tc' && D env tys == D env' tys'
         (LitTy l, LitTy l')
             -> l == l'
-        (ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty')
-            -> D env (tyVarKind tv)    == D env' (tyVarKind tv') &&
+        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')
+            -> D env (varType tv)      == D env' (varType tv') &&
                D (extendCME env tv) ty == D (extendCME env' tv') ty'
         (CoercionTy {}, CoercionTy {})
             -> True
@@ -866,9 +535,9 @@ instance {-# OVERLAPPING #-}
 
 emptyT :: TypeMapX a
 emptyT = TM { tm_var  = emptyTM
-            , tm_app  = EmptyMap
+            , tm_app  = emptyTM
             , tm_tycon  = emptyDNameEnv
-            , tm_forall = EmptyMap
+            , tm_forall = emptyTM
             , tm_tylit  = emptyTyLitMap
             , tm_coerce = Nothing }
 
@@ -894,7 +563,7 @@ lkT (D env ty) m = go ty m
     go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc
     go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)
     go (LitTy l)                   = tm_tylit  >.> lkTyLit l
-    go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty)
+    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)
                                                >=> lkBndr env tv
     go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)
     go (CastTy t _)                = go t
@@ -911,7 +580,7 @@ xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f
 xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }
 xtT (D env (CastTy t _))      f m = xtT (D env t) f m
 xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }
-xtT (D env (ForAllTy (TvBndr tv _) ty))  f m
+xtT (D env (ForAllTy (Bndr tv _) ty))  f m
   = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)
                                 |>> xtBndr env tv f }
 xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)
@@ -1047,7 +716,7 @@ extendCME (CME { cme_next = bv, cme_env = env }) v
   = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }
 
 extendCMEs :: CmEnv -> [Var] -> CmEnv
-extendCMEs env vs = foldl extendCME env vs
+extendCMEs env vs = foldl' extendCME env vs
 
 lookupCME :: CmEnv -> Var -> Maybe BoundVar
 lookupCME (CME { cme_env = env }) v = lookupVarEnv env v
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 4a196057b1..2367c4548d 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -20,7 +20,9 @@ module CoreOpt (
 
 #include "HsVersions.h"
 
-import CoreArity( joinRhsArity, etaExpandToJoinPoint )
+import GhcPrelude
+
+import CoreArity( etaExpandToJoinPoint )
 
 import CoreSyn
 import CoreSubst
@@ -30,10 +32,11 @@ import PprCore  ( pprCoreBindings, pprRules )
 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 import Literal  ( Literal(MachStr) )
 import Id
-import Var      ( varType )
+import Var      ( varType, isNonCoVarId )
 import VarSet
 import VarEnv
 import DataCon
+import Demand( etaExpandStrictSig )
 import OptCoercion ( optCoercion )
 import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                        , isInScope, substTyVarBndr, cloneTyVarBndr )
@@ -84,7 +87,7 @@ little dance in action; the full Simplifier is a lot more complicated.
 
 -}
 
-simpleOptExpr :: CoreExpr -> CoreExpr
+simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
 -- See Note [The simple optimiser]
 -- Do simple optimisation on an expression
 -- The optimisation is very straightforward: just
@@ -101,9 +104,9 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 -- in  (let x = y in ....) we substitute for x; so y's occ-info
 -- may change radically
 
-simpleOptExpr expr
+simpleOptExpr dflags expr
   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
-    simpleOptExprWith init_subst expr
+    simpleOptExprWith dflags init_subst expr
   where
     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
         -- It's potentially important to make a proper in-scope set
@@ -116,32 +119,35 @@ simpleOptExpr expr
         -- It's a bit painful to call exprFreeVars, because it makes
         -- three passes instead of two (occ-anal, and go)
 
-simpleOptExprWith :: Subst -> InExpr -> OutExpr
+simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr
 -- See Note [The simple optimiser]
-simpleOptExprWith subst expr
+simpleOptExprWith dflags subst expr
   = simple_opt_expr init_env (occurAnalyseExpr expr)
   where
-    init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }
+    init_env = SOE { soe_dflags = dflags
+                   , soe_inl = emptyVarEnv
+                   , soe_subst = subst }
 
 ----------------------
 simpleOptPgm :: DynFlags -> Module
-             -> CoreProgram -> [CoreRule] -> [CoreVect]
-             -> IO (CoreProgram, [CoreRule], [CoreVect])
+             -> CoreProgram -> [CoreRule]
+             -> IO (CoreProgram, [CoreRule])
 -- See Note [The simple optimiser]
-simpleOptPgm dflags this_mod binds rules vects
+simpleOptPgm dflags this_mod binds rules
   = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                        (pprCoreBindings occ_anald_binds $$ pprRules rules );
 
-       ; return (reverse binds', rules', vects') }
+       ; return (reverse binds', rules') }
   where
-    occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
-                                       rules vects emptyVarSet binds
+    occ_anald_binds  = occurAnalysePgm this_mod
+                          (\_ -> True)  {- All unfoldings active -}
+                          (\_ -> False) {- No rules active -}
+                          rules binds
 
-    (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
+    (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds
     final_subst = soe_subst final_env
 
     rules' = substRulesForImportedIds final_subst rules
-    vects' = substVects final_subst vects
              -- We never unconditionally inline into rules,
              -- hence paying just a substitution
 
@@ -156,7 +162,8 @@ simpleOptPgm dflags this_mod binds rules vects
 type SimpleClo = (SimpleOptEnv, InExpr)
 
 data SimpleOptEnv
-  = SOE { soe_inl   :: IdEnv SimpleClo
+  = SOE { soe_dflags :: DynFlags
+        , soe_inl   :: IdEnv SimpleClo
              -- Deals with preInlineUnconditionally; things
              -- that occur exactly once and are inlined
              -- without having first been simplified
@@ -171,13 +178,15 @@ instance Outputable SimpleOptEnv where
                             , text "soe_subst =" <+> ppr subst ]
                    <+> text "}"
 
-emptyEnv :: SimpleOptEnv
-emptyEnv = SOE { soe_inl = emptyVarEnv
-               , soe_subst = emptySubst }
+emptyEnv :: DynFlags -> SimpleOptEnv
+emptyEnv dflags
+  = SOE { soe_dflags = dflags
+        , soe_inl = emptyVarEnv
+        , soe_subst = emptySubst }
 
 soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
-soeZapSubst (SOE { soe_subst = subst })
-  = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
+soeZapSubst env@(SOE { soe_subst = subst })
+  = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
 
 soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
 -- Take in-scope set from env1, and the rest from env2
@@ -206,13 +215,13 @@ simple_opt_expr env expr
 
     go (App e1 e2)      = simple_app env e1 [(env,e2)]
     go (Type ty)        = Type     (substTy subst ty)
-    go (Coercion co)    = Coercion (optCoercion (getTCvSubst subst) co)
+    go (Coercion co)    = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
     go (Lit lit)        = Lit lit
     go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
     go (Cast e co)      | isReflCo co' = go e
                         | otherwise    = Cast (go e) co'
                         where
-                          co' = optCoercion (getTCvSubst subst) co
+                          co' = optCoercion (soe_dflags env) (getTCvSubst subst) co
 
     go (Let bind body) = case simple_opt_bind env bind of
                            (env', Nothing)   -> simple_opt_expr env' body
@@ -323,7 +332,7 @@ simple_opt_bind env (Rec prs)
     res_bind          = Just (Rec (reverse rev_prs'))
     prs'              = joinPointBindings_maybe prs `orElse` prs
     (env', bndrs')    = subst_opt_bndrs env (map fst prs')
-    (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')
+    (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')
     do_pr (env, prs) ((b,r), b')
        = (env', case mb_pr of
                   Just pr -> pr : prs
@@ -347,30 +356,43 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
     (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
 
   | Coercion co <- in_rhs
-  , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
+  , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co
   = ASSERT( isCoVar in_bndr )
     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
 
-  | pre_inline_unconditionally
+  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
+    -- The previous two guards got rid of tyvars and coercions
+    -- See Note [CoreSyn type and coercion invariant] in CoreSyn
+    pre_inline_unconditionally
   = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
 
   | otherwise
-  = simple_out_bind_pair env in_bndr mb_out_bndr
-                         (simple_opt_clo env clo)
+  = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
                          occ active stable_unf
   where
     stable_unf = isStableUnfolding (idUnfolding in_bndr)
     active     = isAlwaysActive (idInlineActivation in_bndr)
     occ        = idOccInfo in_bndr
 
+    out_rhs | Just join_arity <- isJoinId_maybe in_bndr
+            = simple_join_rhs join_arity
+            | otherwise
+            = simple_opt_clo env clo
+
+    simple_join_rhs join_arity -- See Note [Preserve join-binding arity]
+      = mkLams join_bndrs' (simple_opt_expr env_body join_body)
+      where
+        env0 = soeSetInScope env rhs_env
+        (join_bndrs, join_body) = collectNBinders join_arity in_rhs
+        (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs
+
     pre_inline_unconditionally :: Bool
     pre_inline_unconditionally
-       | isCoVar in_bndr          = False    -- See Note [Do not inline CoVars unconditionally]
-       | isExportedId in_bndr     = False    --     in SimplUtils
+       | isExportedId in_bndr     = False
        | stable_unf               = False
        | not active               = False    -- Note [Inline prag in simplOpt]
        | not (safe_to_inline occ) = False
-       | otherwise = True
+       | otherwise                = True
 
         -- Unconditionally safe to inline
     safe_to_inline :: OccInfo -> Bool
@@ -403,7 +425,10 @@ simple_out_bind_pair :: SimpleOptEnv
                      -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
 simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
                      occ_info active stable_unf
-  | post_inline_unconditionally
+  | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
+    -- Type and coercion bindings are caught earlier
+    -- See Note [CoreSyn type and coercion invariant]
+    post_inline_unconditionally
   = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
     , Nothing)
 
@@ -417,14 +442,16 @@ simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
 
     post_inline_unconditionally :: Bool
     post_inline_unconditionally
-       | not active                  = False
-       | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
-                                             -- because it might be referred to "earlier"
-       | stable_unf                  = False -- Note [Stable unfoldings and postInlineUnconditionally]
-       | isExportedId in_bndr        = False -- Note [Exported Ids and trivial RHSs]
-       | exprIsTrivial out_rhs       = True
-       | coercible_hack              = True
-       | otherwise                   = False
+       | isExportedId in_bndr  = False -- Note [Exported Ids and trivial RHSs]
+       | stable_unf            = False -- Note [Stable unfoldings and postInlineUnconditionally]
+       | not active            = False --     in SimplUtils
+       | is_loop_breaker       = False -- If it's a loop-breaker of any kind, don't inline
+                                       -- because it might be referred to "earlier"
+       | exprIsTrivial out_rhs = True
+       | coercible_hack        = True
+       | otherwise             = False
+
+    is_loop_breaker = isWeakLoopBreaker occ_info
 
     -- See Note [Getting the map/coerce RULE to work]
     coercible_hack | (Var fun, args) <- collectArgs out_rhs
@@ -447,6 +474,14 @@ trivial ones.  But we do here!  Why?  In the simple optimiser
 Those differences obviate the reasons for not inlining a trivial rhs,
 and increase the benefit for doing so.  So we unconditionally inline trivial
 rhss here.
+
+Note [Preserve join-binding arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Be careful /not/ to eta-reduce the RHS of a join point, lest we lose
+the join-point arity invariant.  Trac #15108 was caused by simplifying
+the RHS with simple_opt_expr, which does eta-reduction.  Solution:
+simplify the RHS of a join point by simplifying under the lambdas
+(which of course should be there).
 -}
 
 ----------------------
@@ -471,8 +506,8 @@ subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
 -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
 -- carefully does not do) because simplOptExpr invalidates it
 
-subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
-  = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
+subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id
+  = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id)
   where
     Subst in_scope id_subst tv_subst cv_subst = subst
 
@@ -513,18 +548,6 @@ wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
 wrapLet Nothing      body = body
 wrapLet (Just (b,r)) body = Let (NonRec b r) body
 
-------------------
-substVects :: Subst -> [CoreVect] -> [CoreVect]
-substVects subst = map (substVect subst)
-
-------------------
-substVect :: Subst -> CoreVect -> CoreVect
-substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)
-substVect _subst vd@(NoVect _)       = vd
-substVect _subst vd@(VectType _ _ _) = vd
-substVect _subst vd@(VectClass _)    = vd
-substVect _subst vd@(VectInst _)     = vd
-
 {-
 Note [Inline prag in simplOpt]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -642,58 +665,43 @@ joinPointBinding_maybe bndr rhs
   = Just (bndr, rhs)
 
   | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
-  , not (bad_unfolding join_arity (idUnfolding bndr))
   , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
-  = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
+  , let str_sig   = idStrictness bndr
+        str_arity = count isId bndrs  -- Strictness demands are for Ids only
+        join_bndr = bndr `asJoinId`        join_arity
+                         `setIdStrictness` etaExpandStrictSig str_arity str_sig
+  = Just (join_bndr, mkLams bndrs body)
 
   | otherwise
   = Nothing
 
-  where
-    -- bad_unfolding returns True if we should /not/ convert a non-join-id
-    -- into a join-id, even though it is AlwaysTailCalled
-    -- See Note [Join points and INLINE pragmas]
-    bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })
-      = isStableSource src && join_arity > joinRhsArity rhs
-    bad_unfolding _ (DFunUnfolding {})
-      = True
-    bad_unfolding _ _
-      = False
-
 joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
 joinPointBindings_maybe bndrs
   = mapM (uncurry joinPointBinding_maybe) bndrs
 
 
-{- Note [Join points and INLINE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f x = let g = \x. not  -- Arity 1
-             {-# INLINE g #-}
-         in case x of
-              A -> g True True
-              B -> g True False
-              C -> blah2
+{- Note [Strictness and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
 
-Here 'g' is always tail-called applied to 2 args, but the stable
-unfolding captured by the INLINE pragma has arity 1.  If we try to
-convert g to be a join point, its unfolding will still have arity 1
-(since it is stable, and we don't meddle with stable unfoldings), and
-Lint will complain (see Note [Invariants on join points], (2a), in
-CoreSyn.  Trac #13413.
+   let f = \x.  if x>200 then e1 else e1
 
-Moreover, since g is going to be inlined anyway, there is no benefit
-from making it a join point.
+and we know that f is strict in x.  Then if we subsequently
+discover that f is an arity-2 join point, we'll eta-expand it to
 
-If it is recursive, and uselessly marked INLINE, this will stop us
-making it a join point, which is annoying.  But occasionally
-(notably in class methods; see Note [Instances and loop breakers] in
-TcInstDcls) we mark recursive things as INLINE but the recursion
-unravels; so ignoring INLINE pragmas on recursive things isn't good
-either.
+   let f = \x y.  if x>200 then e1 else e1
 
+and now it's only strict if applied to two arguments.  So we should
+adjust the strictness info.
 
-************************************************************************
+A more common case is when
+
+   f = \x. error ".."
+
+and again its arity increses (Trac #15517)
+-}
+
+{- *********************************************************************
 *                                                                      *
          exprIsConApp_maybe
 *                                                                      *
@@ -768,9 +776,11 @@ exprIsConApp_maybe (in_scope, id_unf) expr
     go subst (Tick t expr) cont
        | not (tickishIsCode t) = go subst expr cont
     go subst (Cast expr co1) (CC args co2)
-       | Just (args', co1') <- pushCoArgs (subst_co subst co1) args
+       | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
             -- See Note [Push coercions in exprIsConApp_maybe]
-       = go subst expr (CC args' (co1' `mkTransCo` co2))
+       = case m_co1' of
+           MCo co1' -> go subst expr (CC args' (co1' `mkTransCo` co2))
+           MRefl    -> go subst expr (CC args' co2)
     go subst (App fun arg) (CC args co)
        = go subst fun (CC (subst_arg subst arg : args) co)
     go subst (Lam var body) (CC (arg:args) co)
@@ -930,7 +940,7 @@ exprIsLambda_maybe (in_scope_set, id_unf) e
     -- Make sure there is hope to get a lambda
     , Just rhs <- expandUnfolding_maybe (id_unf f)
     -- Optimize, for beta-reduction
-    , let e' =  simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
+    , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as)
     -- Recurse, because of possible casts
     , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
     , let res = Just (x', e'', ts++ts')
@@ -964,36 +974,45 @@ Here we implement the "push rules" from FC papers:
   by pushing the coercion into the arguments
 -}
 
-pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)
-pushCoArgs co []         = return ([], co)
-pushCoArgs co (arg:args) = do { (arg',  co1) <- pushCoArg  co  arg
-                              ; (args', co2) <- pushCoArgs co1 args
-                              ; return (arg':args', co2) }
+pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
+pushCoArgs co []         = return ([], MCo co)
+pushCoArgs co (arg:args) = do { (arg',  m_co1) <- pushCoArg  co  arg
+                              ; case m_co1 of
+                                  MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args
+                                                 ; return (arg':args', m_co2) }
+                                  MRefl  -> return (arg':args, MRefl) }
 
-pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)
+pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)
 -- We have (fun |> co) arg, and we want to transform it to
 --         (fun arg) |> co
 -- This may fail, e.g. if (fun :: N) where N is a newtype
 -- C.f. simplCast in Simplify.hs
 -- 'co' is always Representational
+-- If the returned coercion is Nothing, then it would have been reflexive
+pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty
+                            ; return (Type ty', m_co') }
+pushCoArg co val_arg   = do { (arg_co, m_co') <- pushCoValArg co
+                            ; return (val_arg `mkCast` arg_co, m_co') }
 
-pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty
-                            ; return (Type ty', co') }
-pushCoArg co val_arg   = do { (arg_co, co') <- pushCoValArg co
-                            ; return (mkCast val_arg arg_co, co') }
-
-pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)
+pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)
 -- We have (fun |> co) @ty
 -- Push the coercion through to return
 --         (fun @ty') |> co'
 -- 'co' is always Representational
+-- If the returned coercion is Nothing, then it would have been reflexive;
+-- it's faster not to compute it, though.
 pushCoTyArg co ty
-  | tyL `eqType` tyR
-  = Just (ty, mkRepReflCo (piResultTy tyR ty))
+  -- The following is inefficient - don't do `eqType` here, the coercion
+  -- optimizer will take care of it. See Trac #14737.
+  -- -- | tyL `eqType` tyR
+  -- -- = Just (ty, Nothing)
+
+  | isReflCo co
+  = Just (ty, MRefl)
 
-  | isForAllTy tyL
-  = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )
-    Just (ty `mkCastTy` mkSymCo co1, co2)
+  | isForAllTy_ty tyL
+  = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )
+    Just (ty `mkCastTy` co1, MCo co2)
 
   | otherwise
   = Nothing
@@ -1003,41 +1022,48 @@ pushCoTyArg co ty
        -- tyL = forall (a1 :: k1). ty1
        -- tyR = forall (a2 :: k2). ty2
 
-    co1 = mkNthCo 0 co
-       -- co1 :: k1 ~ k2
-       -- Note that NthCo can extract an equality between the kinds
-       -- of the types related by a coercion between forall-types.
+    co1 = mkSymCo (mkNthCo Nominal 0 co)
+       -- co1 :: k2 ~N k1
+       -- Note that NthCo can extract a Nominal equality between the
+       -- kinds of the types related by a coercion between forall-types.
        -- See the NthCo case in CoreLint.
 
-    co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1)
+    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)
         -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
         -- Arg of mkInstCo is always nominal, hence mkNomReflCo
 
-pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)
+pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)
 -- We have (fun |> co) arg
 -- Push the coercion through to return
 --         (fun (arg |> co_arg)) |> co_res
 -- 'co' is always Representational
+-- If the second returned Coercion is actually Nothing, then no cast is necessary;
+-- the returned coercion would have been reflexive.
 pushCoValArg co
-  | tyL `eqType` tyR
-  = Just (mkRepReflCo arg, mkRepReflCo res)
+  -- The following is inefficient - don't do `eqType` here, the coercion
+  -- optimizer will take care of it. See Trac #14737.
+  -- -- | tyL `eqType` tyR
+  -- -- = Just (mkRepReflCo arg, Nothing)
+
+  | isReflCo co
+  = Just (mkRepReflCo arg, MRefl)
 
   | isFunTy tyL
-  , (co1, co2) <- decomposeFunCo co
+  , (co1, co2) <- decomposeFunCo Representational co
               -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
               -- then co1 :: tyL1 ~ tyR1
               --      co2 :: tyL2 ~ tyR2
   = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
-    Just (mkSymCo co1, co2)
+    Just (mkSymCo co1, MCo co2)
 
   | otherwise
   = Nothing
   where
-    (arg, res)   = splitFunTy tyR
+    arg = funArgTy tyR
     Pair tyL tyR = coercionKind co
 
 pushCoercionIntoLambda
-    :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
+    :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
 -- This implements the Push rule from the paper on coercions
 --    (\x. e) |> co
 -- ===>
@@ -1047,7 +1073,7 @@ pushCoercionIntoLambda in_scope x e co
     , Pair s1s2 t1t2 <- coercionKind co
     , Just (_s1,_s2) <- splitFunTy_maybe s1s2
     , Just (t1,_t2) <- splitFunTy_maybe t1t2
-    = let (co1, co2) = decomposeFunCo co
+    = let (co1, co2) = decomposeFunCo Representational co
           -- Should we optimize the coercions here?
           -- Otherwise they might not match too well
           x' = x `setIdType` t1
@@ -1086,19 +1112,19 @@ pushCoDataCon dc dc_args co
   = let
         tc_arity       = tyConArity to_tc
         dc_univ_tyvars = dataConUnivTyVars dc
-        dc_ex_tyvars   = dataConExTyVars dc
+        dc_ex_tcvars   = dataConExTyCoVars dc
         arg_tys        = dataConRepArgTys dc
 
         non_univ_args  = dropList dc_univ_tyvars dc_args
-        (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
+        (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args
 
         -- Make the "Psi" from the paper
-        omegas = decomposeCo tc_arity co
+        omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)
         (psi_subst, to_ex_arg_tys)
           = liftCoSubstWithEx Representational
                               dc_univ_tyvars
                               omegas
-                              dc_ex_tyvars
+                              dc_ex_tcvars
                               (map exprToType ex_args)
 
           -- Cast the value arguments (which include dictionaries)
@@ -1107,7 +1133,7 @@ pushCoDataCon dc dc_args co
 
         to_ex_args = map Type to_ex_arg_tys
 
-        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
+        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tcvars,
                          ppr arg_tys, ppr dc_args,
                          ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
     in
@@ -1140,7 +1166,7 @@ collectBindersPushingCo e
     go bs e           = (reverse bs, e)
 
     -- We are in a cast; peel off casts until we hit a lambda.
-    go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
     -- (go_c bs e c) is same as (go bs e (e |> c))
     go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)
     go_c bs (Lam b e)    co  = go_lam bs b e co
@@ -1148,20 +1174,28 @@ collectBindersPushingCo e
 
     -- We are in a lambda under a cast; peel off lambdas and build a
     -- new coercion for the body.
-    go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
     -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
     go_lam bs b e co
       | isTyVar b
       , let Pair tyL tyR = coercionKind co
-      , ASSERT( isForAllTy tyL )
-        isForAllTy tyR
-      , isReflCo (mkNthCo 0 co)  -- See Note [collectBindersPushingCo]
+      , ASSERT( isForAllTy_ty tyL )
+        isForAllTy_ty tyR
+      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]
       = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
 
+      | isCoVar b
+      , let Pair tyL tyR = coercionKind co
+      , ASSERT( isForAllTy_co tyL )
+        isForAllTy_co tyR
+      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]
+      , let cov = mkCoVarCo b
+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))
+
       | isId b
       , let Pair tyL tyR = coercionKind co
       , ASSERT( isFunTy tyL) isFunTy tyR
-      , (co_arg, co_res) <- decomposeFunCo co
+      , (co_arg, co_res) <- decomposeFunCo Representational co
       , isReflCo co_arg  -- See Note [collectBindersPushingCo]
       = go_c (b:bs) e co_res
 
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 4f7a0da835..9c2954d4ef 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -8,12 +8,15 @@ Core pass to saturate constructors and PrimOps
 {-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
 
 module CorePrep (
-      corePrepPgm, corePrepExpr, cvtLitInteger,
-      lookupMkIntegerName, lookupIntegerSDataConName
+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
+      lookupMkIntegerName, lookupIntegerSDataConName,
+      lookupMkNaturalName, lookupNaturalSDataConName
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import OccurAnal
 
 import HscTypes
@@ -58,12 +61,14 @@ import Name             ( NamedThing(..), nameSrcSpan )
 import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import Data.Bits
 import MonadUtils       ( mapAccumLM )
-import Data.List        ( mapAccumL )
+import Data.List        ( mapAccumL, foldl' )
 import Control.Monad
+import CostCentre       ( CostCentre, ccFromThisModule )
+import qualified Data.Set as S
 
 {-
 -- ---------------------------------------------------------------------------
--- Overview
+-- Note [CorePrep Overview]
 -- ---------------------------------------------------------------------------
 
 The goal of this pass is to prepare for code generation.
@@ -118,10 +123,16 @@ The goal of this pass is to prepare for code generation.
     special case where we use the S# constructor for Integers that
     are in the range of Int.
 
-11. Uphold tick consistency while doing this: We move ticks out of
+11. Same for LitNatural.
+
+12. Uphold tick consistency while doing this: We move ticks out of
     (non-type) applications where we can, and make sure that we
     annotate according to scoping rules when floating.
 
+13. Collect cost centres (including cost centres in unfoldings) if we're in
+    profiling mode. We have to do this here beucase we won't have unfoldings
+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
+
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
@@ -167,7 +178,7 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 -}
 
 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
-            -> IO CoreProgram
+            -> IO (CoreProgram, S.Set CostCentre)
 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     withTiming (pure dflags)
                (text "CorePrep"<+>brackets (ppr this_mod))
@@ -175,7 +186,13 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
 
-    let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
+    let cost_centres
+          | WayProf `elem` ways dflags
+          = collectCostCentres this_mod binds
+          | otherwise
+          = S.empty
+
+        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
             -- NB: we must feed mkImplicitBinds through corePrep too
             -- so that they are suitably cloned and eta-expanded
 
@@ -185,7 +202,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
-    return binds_out
+    return (binds_out, cost_centres)
   where
     dflags = hsc_dflags hsc_env
 
@@ -405,23 +422,21 @@ cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cpCloneBndr env bndr
        ; let dmd         = idDemandInfo bndr
              is_unlifted = isUnliftedType (idType bndr)
-       ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
-                                          dmd
-                                          is_unlifted
-                                          env bndr1 rhs
+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
+                                   dmd is_unlifted
+                                   env bndr1 rhs
        -- See Note [Inlining in CorePrep]
-       ; if exprIsTrivial rhs2 && isNotTopLevel top_lvl
-            then return (extendCorePrepEnvExpr env bndr rhs2, floats, Nothing)
+       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
+            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
             else do {
 
-       ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2
+       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
 
-        -- We want bndr'' in the envt, because it records
-        -- the evaluated-ness of the binder
-       ; return (extendCorePrepEnv env bndr bndr2,
+       ; return (extendCorePrepEnv env bndr bndr1,
                  addFloat floats new_float,
                  Nothing) }}
-  | otherwise -- See Note [Join points and floating]
+
+  | otherwise -- A join point; see Note [Join points and floating]
   = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
     do { (_, bndr1) <- cpCloneBndr env bndr
        ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
@@ -432,14 +447,17 @@ cpeBind top_lvl env (NonRec bndr rhs)
 cpeBind top_lvl env (Rec pairs)
   | not (isJoinId (head bndrs))
   = do { (env', bndrs1) <- cpCloneBndrs env bndrs
-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
+                           bndrs1 rhss
 
-       ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
-             all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
+       ; let (floats_s, rhss1) = unzip stuff
+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
                                            (concatFloats floats_s)
-       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
+
+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
                  unitFloat (FloatLet (Rec all_pairs)),
                  Nothing) }
+
   | otherwise -- See Note [Join points and floating]
   = do { (env', bndrs1) <- cpCloneBndrs env bndrs
        ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
@@ -459,9 +477,10 @@ cpeBind top_lvl env (Rec pairs)
 
 ---------------
 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-        -> CorePrepEnv -> Id -> CoreExpr
-        -> UniqSM (Floats, Id, CpeRhs)
+        -> CorePrepEnv -> OutId -> CoreExpr
+        -> UniqSM (Floats, CpeRhs)
 -- Used for all bindings
+-- The binder is already cloned, hence an OutId
 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
   = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
     do { (floats1, rhs1) <- cpeRhsE env rhs
@@ -483,15 +502,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
         -- Wrap floating ticks
        ; let (floats4, rhs4) = wrapTicks floats3 rhs3
 
-        -- Record if the binder is evaluated
-        -- and otherwise trim off the unfolding altogether
-        -- It's not used by the code generator; getting rid of it reduces
-        -- heap usage and, since we may be changing uniques, we'd have
-        -- to substitute to keep it right
-       ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding
-                   | otherwise      = bndr `setIdUnfolding` noUnfolding
-
-       ; return (floats4, bndr', rhs4) }
+       ; return (floats4, rhs4) }
   where
     platform = targetPlatform (cpe_dynFlags env)
 
@@ -571,7 +582,6 @@ cpeJoinPair env bndr rhs
 {-
 Note [Arity and join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Up to now, we've allowed a join point to have an arity greater than its join
 arity (minus type arguments), since this is what's useful for eta expansion.
 However, for code gen purposes, its arity must be exactly the number of value
@@ -601,9 +611,12 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 
 cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
 cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
-cpeRhsE env (Lit (LitInteger i _))
+cpeRhsE env (Lit (LitNumber LitNumInteger i _))
     = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
                    (cpe_integerSDataCon env) i)
+cpeRhsE env (Lit (LitNumber LitNumNatural i _))
+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
+                   (cpe_naturalSDataCon env) i)
 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 cpeRhsE env expr@(App {}) = cpeApp env expr
@@ -642,9 +655,7 @@ cpeRhsE env expr@(Lam {})
 
 cpeRhsE env (Case scrut bndr ty alts)
   = do { (floats, scrut') <- cpeBody env scrut
-       ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
-            -- Record that the case binder is evaluated in the alternatives
-       ; (env', bndr2) <- cpCloneBndr env bndr1
+       ; (env', bndr2) <- cpCloneBndr env bndr
        ; let alts'
                  -- This flag is intended to aid in debugging strictness
                  -- analysis bugs. These are particularly nasty to chase down as
@@ -688,6 +699,24 @@ cvtLitInteger dflags mk_integer _ i
         bits = 31
         mask = 2 ^ bits - 1
 
+cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Natural to the low-level
+-- representation.
+-- See Note [Natural literals] in Literal
+cvtLitNatural dflags _ (Just sdatacon) i
+  | inWordRange dflags i -- Special case for small naturals
+    = mkConApp sdatacon [Lit (mkMachWord dflags i)]
+
+cvtLitNatural dflags mk_natural _ i
+    = mkApps (Var mk_natural) [words]
+  where words = mkListExpr wordTy (f i)
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp wordDataCon [Lit (mkMachWord dflags low)] : f high
+        bits = 32
+        mask = 2 ^ bits - 1
+
 -- ---------------------------------------------------------------------------
 --              CpeBody: produces a result satisfying CpeBody
 -- ---------------------------------------------------------------------------
@@ -823,6 +852,7 @@ cpeApp top_env expr
           in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
     cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
         | f `hasKey` runRWKey
+        -- See Note [runRW magic]
         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
         -- is why we return a CorePrepEnv as well)
         = case arg of
@@ -916,11 +946,51 @@ isLazyExpr (Tick _ e)              = isLazyExpr e
 isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
 isLazyExpr _                       = False
 
+{- Note [runRW magic]
+~~~~~~~~~~~~~~~~~~~~~
+Some definitions, for instance @runST@, must have careful control over float out
+of the bindings in their body. Consider this use of @runST@,
+
+    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
+                             (_, s'') = fill_in_array_or_something a x s'
+                         in freezeArray# a s'' )
+
+If we inline @runST@, we'll get:
+
+    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
+              (_, s'') = fill_in_array_or_something a x s'
+          in freezeArray# a s''
+
+And now if we allow the @newArray#@ binding to float out to become a CAF,
+we end up with a result that is totally and utterly wrong:
+
+    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
+        in \ x ->
+            let (_, s'') = fill_in_array_or_something a x s'
+            in freezeArray# a s''
+
+All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
+must be prevented.
+
+This is what @runRW#@ gives us: by being inlined extremely late in the
+optimization (right before lowering to STG, in CorePrep), we can ensure that
+no further floating will occur. This allows us to safely inline things like
+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).
+
+'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
+pragma.  It is levity-polymorphic.
+
+    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
+           => (State# RealWorld -> (# State# RealWorld, o #))
+                              -> (# State# RealWorld, o #)
+
+It needs no special treatment in GHC except this special inlining here
+in CorePrep (and in ByteCodeGen).
+
 -- ---------------------------------------------------------------------------
 --      CpeArg: produces a result satisfying CpeArg
 -- ---------------------------------------------------------------------------
 
-{-
 Note [ANF-ising literal string arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1040,16 +1110,26 @@ saturateDataToTag sat_expr
     eval_data2tag_arg other     -- Should not happen
         = pprPanic "eval_data2tag" (ppr other)
 
-{-
-Note [dataToTag magic]
-~~~~~~~~~~~~~~~~~~~~~~
-Horrid: we must ensure that the arg of data2TagOp is evaluated
-  (data2tag x) -->  (case x of y -> data2tag y)
+{- Note [dataToTag magic]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that the arg of data2TagOp is evaluated. So
+in general CorePrep does this transformation:
+  data2tag e   -->   case e of y -> data2tag y
 (yuk yuk) take into account the lambdas we've now introduced
 
 How might it not be evaluated?  Well, we might have floated it out
 of the scope of a `seq`, or dropped the `seq` altogether.
 
+We only do this if 'e' is not a WHNF.  But if it's a simple
+variable (common case) we need to know its evaluated-ness flag.
+Example:
+   data T = MkT !Bool
+   f v = case v of
+           MkT y -> dataToTag# y
+Here we don't want to generate an extra case on 'y', because it's
+already evaluated.  So we want to keep the evaluated-ness flag
+on y.  See Note [Preserve evaluated-ness in CorePrep].
+
 
 ************************************************************************
 *                                                                      *
@@ -1332,8 +1412,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
     -- the new binding is static. However it can't mention
     -- any non-static things or it would *already* be Caffy
     rhs_ok = rhsIsStatic platform (\_ -> False)
-                         (\i -> pprPanic "rhsIsStatic" (integer i))
-                         -- Integer literals should not show up
+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))
+                         -- Integer or Natural literals should not show up
 
 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec dmd is_unlifted floats rhs
@@ -1442,7 +1522,9 @@ data CorePrepEnv
         --      see Note [lazyId magic], Note [Inlining in CorePrep]
         --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
         , cpe_mkIntegerId     :: Id
+        , cpe_mkNaturalId     :: Id
         , cpe_integerSDataCon :: Maybe DataCon
+        , cpe_naturalSDataCon :: Maybe DataCon
     }
 
 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
@@ -1450,13 +1532,24 @@ lookupMkIntegerName dflags hsc_env
     = guardIntegerUse dflags $ liftM tyThingId $
       lookupGlobal hsc_env mkIntegerName
 
+lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
+lookupMkNaturalName dflags hsc_env
+    = guardNaturalUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkNaturalName
+
 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
     IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
                   lookupGlobal hsc_env integerSDataConName
     IntegerSimple -> return Nothing
 
--- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
+lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupNaturalSDataConName dflags hsc_env = case cIntegerLibraryType of
+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env naturalSDataConName
+    IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
 guardIntegerUse :: DynFlags -> IO a -> IO a
 guardIntegerUse dflags act
   | thisPackage dflags == primUnitId
@@ -1465,15 +1558,33 @@ guardIntegerUse dflags act
   = return $ panic "Can't use Integer in integer-*"
   | otherwise = act
 
+-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
+--
+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
+guardNaturalUse :: DynFlags -> IO a -> IO a
+guardNaturalUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Natural in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Natural in integer-*"
+  | thisPackage dflags == baseUnitId
+  = return $ panic "Can't use Natural in base"
+  | otherwise = act
+
 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
 mkInitialCorePrepEnv dflags hsc_env
     = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+         mkNaturalId <- lookupMkNaturalName dflags hsc_env
          integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
          return $ CPE {
                       cpe_dynFlags = dflags,
                       cpe_env = emptyVarEnv,
                       cpe_mkIntegerId = mkIntegerId,
-                      cpe_integerSDataCon = integerSDataCon
+                      cpe_mkNaturalId = mkNaturalId,
+                      cpe_integerSDataCon = integerSDataCon,
+                      cpe_naturalSDataCon = naturalSDataCon
                   }
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1498,30 +1609,74 @@ lookupCorePrepEnv cpe id
 getMkIntegerId :: CorePrepEnv -> Id
 getMkIntegerId = cpe_mkIntegerId
 
+getMkNaturalId :: CorePrepEnv -> Id
+getMkNaturalId = cpe_mkNaturalId
+
 ------------------------------------------------------------------------------
 -- Cloning binders
 -- ---------------------------------------------------------------------------
 
-cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
+cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
 
-cpCloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
+cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
 cpCloneBndr env bndr
-  | isLocalId bndr, not (isCoVar bndr)
-  = do bndr' <- setVarUnique bndr <$> getUniqueM
-
-       -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
-       -- so that we can drop more stuff as dead code.
-       -- See also Note [Dead code in CorePrep]
-       let bndr'' = bndr' `setIdUnfolding` noUnfolding
-                          `setIdSpecialisation` emptyRuleInfo
-       return (extendCorePrepEnv env bndr bndr'', bndr'')
-
-  | otherwise   -- Top level things, which we don't want
-                -- to clone, have become GlobalIds by now
-                -- And we don't clone tyvars, or coercion variables
+  | not (isId bndr)
   = return (env, bndr)
 
+  | otherwise
+  = do { bndr' <- clone_it bndr
+
+       -- Drop (now-useless) rules/unfoldings
+       -- See Note [Drop unfoldings and rules]
+       -- and Note [Preserve evaluated-ness in CorePrep]
+       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
+                          -- Simplifier will set the Id's unfolding
+
+             bndr'' = bndr' `setIdUnfolding`      unfolding'
+                            `setIdSpecialisation` emptyRuleInfo
+
+       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
+  where
+    clone_it bndr
+      | isLocalId bndr, not (isCoVar bndr)
+      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
+      | otherwise   -- Top level things, which we don't want
+                    -- to clone, have become GlobalIds by now
+                    -- And we don't clone tyvars, or coercion variables
+      = return bndr
+
+{- Note [Drop unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to drop the unfolding/rules on every Id:
+
+  - We are now past interface-file generation, and in the
+    codegen pipeline, so we really don't need full unfoldings/rules
+
+  - The unfolding/rule may be keeping stuff alive that we'd like
+    to discard.  See  Note [Dead code in CorePrep]
+
+  - Getting rid of unnecessary unfoldings reduces heap usage
+
+  - We are changing uniques, so if we didn't discard unfoldings/rules
+    we'd have to substitute in them
+
+HOWEVER, we want to preserve evaluated-ness; see
+Note [Preserve evaluated-ness in CorePrep]
+
+Note [Preserve evaluated-ness in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to preserve the evaluated-ness of each binder (via
+evaldUnfolding) for two reasons
+
+* In the code generator if we have
+     case x of y { Red -> e1; DEFAULT -> y }
+  we can return 'y' rather than entering it, if we know
+  it is evaluated (Trac #14626)
+
+* In the DataToTag magic (in CorePrep itself) we rely on
+  evaluated-ness.  See Note Note [dataToTag magic].
+-}
 
 ------------------------------------------------------------------------------
 -- Cloning ccall Ids; each must have a unique name,
@@ -1598,3 +1753,39 @@ wrapTicks (Floats flag floats0) expr =
                                              (ppr other)
         wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
         wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+
+------------------------------------------------------------------------------
+-- Collecting cost centres
+-- ---------------------------------------------------------------------------
+
+-- | Collect cost centres defined in the current module, including those in
+-- unfoldings.
+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
+collectCostCentres mod_name
+  = foldl' go_bind S.empty
+  where
+    go cs e = case e of
+      Var{} -> cs
+      Lit{} -> cs
+      App e1 e2 -> go (go cs e1) e2
+      Lam _ e -> go cs e
+      Let b e -> go (go_bind cs b) e
+      Case scrt _ _ alts -> go_alts (go cs scrt) alts
+      Cast e _ -> go cs e
+      Tick (ProfNote cc _ _) e ->
+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
+      Tick _ e -> go cs e
+      Type{} -> cs
+      Coercion{} -> cs
+
+    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
+
+    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
+    go_bind cs (NonRec b e) =
+      go (maybe cs (go cs) (get_unf b)) e
+    go_bind cs (Rec bs) =
+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
+
+    -- Unfoldings may have cost centres that in the original definion are
+    -- optimized away, see #5889.
+    get_unf = maybeUnfoldingTemplate . realIdUnfolding
diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
index d426bd3581..7de8923a71 100644
--- a/compiler/coreSyn/CoreSeq.hs
+++ b/compiler/coreSyn/CoreSeq.hs
@@ -10,6 +10,8 @@ module CoreSeq (
         megaSeqIdInfo, seqRuleInfo, seqBinds,
     ) where
 
+import GhcPrelude
+
 import CoreSyn
 import IdInfo
 import Demand( seqDemand, seqStrictSig )
diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs
index cb73d147a8..826ffe171e 100644
--- a/compiler/coreSyn/CoreStats.hs
+++ b/compiler/coreSyn/CoreStats.hs
@@ -11,6 +11,8 @@ module CoreStats (
         CoreStats(..), coreBindsStats, exprStats,
     ) where
 
+import GhcPrelude
+
 import BasicTypes
 import CoreSyn
 import Outputable
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 919d9e8cd0..2df3fb1b52 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -36,6 +36,8 @@ module CoreSubst (
 #include "HsVersions.h"
 
 
+import GhcPrelude
+
 import CoreSyn
 import CoreFVs
 import CoreSeq
@@ -77,19 +79,9 @@ import Data.List
 --
 -- Some invariants apply to how you use the substitution:
 --
--- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/
--- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the
--- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.
---
--- 2. #apply_once# You may apply the substitution only /once/
---
--- There are various ways of setting up the in-scope set such that the first of these invariants hold:
---
--- * Arrange that the in-scope set really is all the things in scope
---
--- * Arrange that it's the free vars of the range of the substitution
+-- 1. Note [The substitution invariant] in TyCoRep
 --
--- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash
+-- 2. Note [Substitutions apply only once] in TyCoRep
 data Subst
   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
                       -- applying the substitution
@@ -97,7 +89,7 @@ data Subst
           TvSubstEnv  -- Substitution from TyVars to Types
           CvSubstEnv  -- Substitution from CoVars to Coercions
 
-        -- INVARIANT 1: See #in_scope_invariant#
+        -- INVARIANT 1: See TyCoRep Note [The substitution invariant]
         -- This is what lets us deal with name capture properly
         -- It's a hard invariant to check...
         --
@@ -179,7 +171,7 @@ mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
 mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
 
--- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
+-- | Find the in-scope set: see TyCoRep Note [The substitution invariant]
 substInScope :: Subst -> InScopeSet
 substInScope (Subst in_scope _ _ _) = in_scope
 
@@ -189,7 +181,8 @@ zapSubstEnv :: Subst -> Subst
 zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 
 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
--- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+-- such that TyCoRep Note [The substitution invariant]
+-- holds after extending the substitution like this
 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
 extendIdSubst (Subst in_scope ids tvs cvs) v r
@@ -205,8 +198,8 @@ extendIdSubstList (Subst in_scope ids tvs cvs) prs
 -- | Add a substitution for a 'TyVar' to the 'Subst'
 -- The 'TyVar' *must* be a real TyVar, and not a CoVar
 -- You must ensure that the in-scope set is such that
--- the "CoreSubst#in_scope_invariant" is true after extending
--- the substitution like this.
+-- TyCoRep Note [The substitution invariant] holds
+-- after extending the substitution like this.
 extendTvSubst :: Subst -> TyVar -> Type -> Subst
 extendTvSubst (Subst in_scope ids tvs cvs) tv ty
   = ASSERT( isTyVar tv )
@@ -219,8 +212,10 @@ extendTvSubstList subst vrs
   where
     extend subst (v, r) = extendTvSubst subst v r
 
--- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
--- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst':
+-- you must ensure that the in-scope set satisfies
+-- TyCoRep Note [The substitution invariant]
+-- after extending the substitution like this
 extendCvSubst :: Subst -> CoVar -> Coercion -> Subst
 extendCvSubst (Subst in_scope ids tvs cvs) v r
   = ASSERT( isCoVar v )
@@ -343,7 +338,8 @@ instance Outputable Subst where
 -}
 
 -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only
--- apply the substitution /once/: see "CoreSubst#apply_once"
+-- apply the substitution /once/:
+-- see Note [Substitutions apply only once] in TyCoRep
 --
 -- Do *not* attempt to short-cut in the case of an empty substitution!
 -- See Note [Extending the Subst]
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 99478d2b66..aa27d7a7fb 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -5,6 +5,7 @@
 
 {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE BangPatterns #-}
 
 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
 module CoreSyn (
@@ -18,7 +19,7 @@ module CoreSyn (
         InId, InBind, InExpr, InAlt, InArg, InType, InKind,
                InBndr, InVar, InCoercion, InTyVar, InCoVar,
         OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind,
-               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,
+               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion,
 
         -- ** 'Expr' construction
         mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,
@@ -40,12 +41,12 @@ module CoreSyn (
         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
         collectBinders, collectTyBinders, collectTyAndValBinders,
         collectNBinders,
-        collectArgs, collectArgsTicks, flattenBinds,
+        collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
 
         exprToType, exprToCoercion_maybe,
         applyTypeToArg,
 
-        isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+        isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount,
         isRuntimeArg, isRuntimeVar,
 
         -- * Tick-related functions
@@ -77,7 +78,7 @@ module CoreSyn (
         collectAnnArgs, collectAnnArgsTicks,
 
         -- ** Operations on annotations
-        deAnnotate, deAnnotate', deAnnAlt,
+        deAnnotate, deAnnotate', deAnnAlt, deAnnBind,
         collectAnnBndrs, collectNAnnBndrs,
 
         -- * Orphanhood
@@ -92,13 +93,12 @@ module CoreSyn (
         ruleArity, ruleName, ruleIdName, ruleActivation,
         setRuleIdName, ruleModule,
         isBuiltinRule, isLocalRule, isAutoRule,
-
-        -- * Core vectorisation declarations data type
-        CoreVect(..)
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CostCentre
 import VarEnv( InScopeSet )
 import Var
@@ -110,7 +110,6 @@ import NameEnv( NameEnv, emptyNameEnv )
 import Literal
 import DataCon
 import Module
-import TyCon
 import BasicTypes
 import DynFlags
 import Outputable
@@ -174,6 +173,7 @@ These data types are the heart of the compiler
 -- The language consists of the following elements:
 --
 -- *  Variables
+--    See Note [Variable occurrences in Core]
 --
 -- *  Primitive literals
 --
@@ -188,29 +188,10 @@ These data types are the heart of the compiler
 --    this corresponds to allocating a thunk for the things
 --    bound and then executing the sub-expression.
 --
---    #top_level_invariant#
---    #letrec_invariant#
---
---    The right hand sides of all top-level and recursive @let@s
---    /must/ be of lifted type (see "Type#type_classification" for
---    the meaning of /lifted/ vs. /unlifted/). There is one exception
---    to this rule, top-level @let@s are allowed to bind primitive
---    string literals, see Note [CoreSyn top-level string literals].
---
+--    See Note [CoreSyn letrec invariant]
 --    See Note [CoreSyn let/app invariant]
 --    See Note [Levity polymorphism invariants]
---
---    #type_let#
---    We allow a /non-recursive/ let to bind a type variable, thus:
---
---    > Let (NonRec tv (Type ty)) body
---
---    This can be very convenient for postponing type substitutions until
---    the next run of the simplifier.
---
---    At the moment, the rest of the compiler only deals with type-let
---    in a Let expression, rather than at top level.  We may want to revist
---    this choice.
+--    See Note [CoreSyn type and coercion invariant]
 --
 -- *  Case expression. Operationally this corresponds to evaluating
 --    the scrutinee (expression examined) to weak head normal form
@@ -311,16 +292,17 @@ data AltCon
 -- This instance is a bit shady. It can only be used to compare AltCons for
 -- a single type constructor. Fortunately, it seems quite unlikely that we'll
 -- ever need to compare AltCons for different type constructors.
+-- The instance adheres to the order described in [CoreSyn case invariants]
 instance Ord AltCon where
   compare (DataAlt con1) (DataAlt con2) =
     ASSERT( dataConTyCon con1 == dataConTyCon con2 )
     compare (dataConTag con1) (dataConTag con2)
-  compare (DataAlt _) _ = LT
-  compare _ (DataAlt _) = GT
+  compare (DataAlt _) _ = GT
+  compare _ (DataAlt _) = LT
   compare (LitAlt l1) (LitAlt l2) = compare l1 l2
-  compare (LitAlt _) DEFAULT = LT
+  compare (LitAlt _) DEFAULT = GT
   compare DEFAULT DEFAULT = EQ
-  compare DEFAULT _ = GT
+  compare DEFAULT _ = LT
 
 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
 
@@ -344,7 +326,7 @@ In particular, scrutinee variables `x` in expressions of the form
 "wild_". These "wild" variables may appear in the body of the
 case-expression, and further, may be shadowed within the body.
 
-So the Unique in an Var is not really unique at all.  Still, it's very
+So the Unique in a Var is not really unique at all.  Still, it's very
 useful to give a constant-time equality/ordering for Vars, and to give
 a key that can be used to make sets of Vars (VarSet), or mappings from
 Vars to other things (VarEnv).   Moreover, if you do want to eliminate
@@ -371,13 +353,25 @@ PrelRules for the rationale for this restriction.
 
 -------------------------- CoreSyn INVARIANTS ---------------------------
 
-Note [CoreSyn top-level invariant]
+Note [Variable occurrences in Core]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #toplevel_invariant#
+Variable /occurrences/ are never CoVars, though /bindings/ can be.
+All CoVars appear in Coercions.
+
+For example
+  \(c :: Age~#Int) (d::Int). d |> (sym c)
+Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in
+a Coercion, (sym c).
 
 Note [CoreSyn letrec invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #letrec_invariant#
+The right hand sides of all top-level and recursive @let@s
+/must/ be of lifted type (see "Type#type_classification" for
+the meaning of /lifted/ vs. /unlifted/).
+
+There is one exception to this rule, top-level @let@s are
+allowed to bind primitive string literals: see
+Note [CoreSyn top-level string literals].
 
 Note [CoreSyn top-level string literals]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -398,10 +392,10 @@ The solution is simply to allow top-level unlifted binders. We can't allow
 arbitrary unlifted expression at the top-level though, unlifted binders cannot
 be thunks, so we just allow string literals.
 
-It is important to note that top-level primitive string literals cannot be
-wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects
-to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive
-string bindings; anything else and things break. CoreLint checks this invariant.
+We allow the top-level primitive string literals to be wrapped in Ticks
+in the same way they can be wrapped when nested in an expression.
+CoreToSTG currently discards Ticks around top-level primitive string literals.
+See Trac #14779.
 
 Also see Note [Compilation plan for top-level string literals].
 
@@ -411,7 +405,7 @@ Here is a summary on how top-level string literals are handled by various
 parts of the compilation pipeline.
 
 * In the source language, there is no way to bind a primitive string literal
-  at the top leve.
+  at the top level.
 
 * In Core, we have a special rule that permits top-level Addr# bindings. See
   Note [CoreSyn top-level string literals]. Core-to-core passes may introduce
@@ -451,6 +445,27 @@ which will generate a @case@ if necessary
 The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in
 coreSyn/MkCore.
 
+Note [CoreSyn type and coercion invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow a /non-recursive/, /non-top-level/ let to bind type and
+coercion variables.  These can be very convenient for postponing type
+substitutions until the next run of the simplifier.
+
+* A type variable binding must have a RHS of (Type ty)
+
+* A coercion variable binding must have a RHS of (Coercion co)
+
+  It is possible to have terms that return a coercion, but we use
+  case-binding for those; e.g.
+     case (eq_sel d) of (co :: a ~# b) -> blah
+  where eq_sel :: (a~b) -> (a~#b)
+
+  Or even even
+      case (df @Int) of (co :: a ~# b) -> blah
+  Which is very exotic, and I think never encountered; but see
+  Note [Equality superclasses in quantified constraints]
+  in TcCanonical
+
 Note [CoreSyn case invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See #case_invariants#
@@ -703,33 +718,64 @@ polymorphic in its return type. That is, if its type is
   forall a1 ... ak. t1 -> ... -> tn -> r
 
 where its join arity is k+n, none of the type parameters ai may occur free in r.
-The most direct explanation is that given
 
-  join j @a1 ... @ak x1 ... xn = e1 in e2
+In some way, this falls out of the fact that given
+
+  join
+     j @a1 ... @ak x1 ... xn = e1
+  in e2
+
+then all calls to `j` are in tail-call positions of `e`, and expressions in
+tail-call positions in `e` have the same type as `e`.
+Therefore the type of `e1` -- the return type of the join point -- must be the
+same as the type of e2.
+Since the type variables aren't bound in `e2`, its type can't include them, and
+thus neither can the type of `e1`.
+
+This unfortunately prevents the `go` in the following code from being a
+join-point:
 
-our typing rules require `e1` and `e2` to have the same type. Therefore the type
-of `e1`---the return type of the join point---must be the same as the type of
-e2. Since the type variables aren't bound in `e2`, its type can't include them,
-and thus neither can the type of `e1`.
+  iter :: forall a. Int -> (a -> a) -> a -> a
+  iter @a n f x = go @a n f x
+    where
+      go :: forall a. Int -> (a -> a) -> a -> a
+      go @a 0 _ x = x
+      go @a n f x = go @a (n-1) f (f x)
 
-There's a deeper explanation in terms of the sequent calculus in Section 5.3 of
-a previous paper:
+In this case, a static argument transformation would fix that (see
+ticket #14620):
 
-  Paul Downen, Luke Maurer, Zena Ariola, and Simon Peyton Jones. "Sequent
-  calculus as a compiler intermediate language." ICFP'16.
+  iter :: forall a. Int -> (a -> a) -> a -> a
+  iter @a n f x = go' @a n f x
+    where
+      go' :: Int -> (a -> a) -> a -> a
+      go' 0 _ x = x
+      go' n f x = go' (n-1) f (f x)
 
-  https://www.microsoft.com/en-us/research/wp-content/uploads/2016/04/sequent-calculus-icfp16.pdf
+In general, loopification could be employed to do that (see #14068.)
 
-The quick version: Consider the CPS term (the paper uses the sequent calculus,
-but we can translate readily):
+Can we simply drop the requirement, and allow `go` to be a join-point? We
+could, and it would work. But we could not longer apply the case-of-join-point
+transformation universally. This transformation would do:
 
-  \k -> join j @a1 ... @ak x1 ... xn = e1 k in e2 k
+  case (join go @a n f x = case n of 0 -> x
+                                     n -> go @a (n-1) f (f x)
+        in go @Bool n neg True) of
+    True -> e1; False -> e2
 
-Since `j` is a join point, it doesn't bind a continuation variable but reuses
-the variable `k` from the context. But the parameters `ai` are not in `k`'s
-scope, and `k`'s type determines the return type of `j`; thus the `ai`s don't
-appear in the return type of `j`. (Also, since `e1` and `e2` are passed the same
-continuation, they must have the same type; hence the direct explanation above.)
+ ===>
+
+  join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2
+                          n -> go @a (n-1) f (f x)
+  in go @Bool n neg True
+
+but that is ill-typed, as `x` is type `a`, not `Bool`.
+
+
+This also justifies why we do not consider the `e` in `e |> co` to be in
+tail position: A cast changes the type, but the type must be the same. But
+operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for
+ideas how to fix this.
 
 ************************************************************************
 *                                                                      *
@@ -759,6 +805,7 @@ type OutBind     = CoreBind
 type OutExpr     = CoreExpr
 type OutAlt      = CoreAlt
 type OutArg      = CoreArg
+type MOutCoercion = MCoercion
 
 
 {- *********************************************************************
@@ -856,7 +903,7 @@ data TickishScoping =
 
     -- | Soft scoping: We want all code that is covered to stay
     -- covered.  Note that this scope type does not forbid
-    -- transformations from happening, as as long as all results of
+    -- transformations from happening, as long as all results of
     -- the transformations are still covered by this tick or a copy of
     -- it. For example
     --
@@ -1270,23 +1317,6 @@ setRuleIdName nm ru = ru { ru_fn = nm }
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Vectorisation declarations}
-*                                                                      *
-************************************************************************
-
-Representation of desugared vectorisation declarations that are fed to the vectoriser (via
-'ModGuts').
--}
-
-data CoreVect = Vect      Id   CoreExpr
-              | NoVect    Id
-              | VectType  Bool TyCon (Maybe TyCon)
-              | VectClass TyCon                     -- class tycon
-              | VectInst  Id                        -- instance dfun (always SCALAR)  !!!FIXME: should be superfluous now
-
-{-
-************************************************************************
-*                                                                      *
                 Unfoldings
 *                                                                      *
 ************************************************************************
@@ -1800,12 +1830,12 @@ mkVarApps :: Expr b -> [Var] -> Expr b
 -- use 'MkCore.mkCoreConApps' if possible
 mkConApp      :: DataCon -> [Arg b] -> Expr b
 
-mkApps    f args = foldl App                       f args
-mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
-mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
+mkApps    f args = foldl' App                       f args
+mkCoApps  f args = foldl' (\ e a -> App e (Coercion a)) f args
+mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
-mkTyApps  f args = foldl (\ e a -> App e (mkTyArg a)) f args
+mkTyApps  f args = foldl' (\ e a -> App e (mkTyArg a)) f args
 
 mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
 mkConApp2 con tys arg_ids = Var (dataConWorkId con)
@@ -2021,7 +2051,7 @@ collectNBinders orig_n orig_expr
     go n bs (Lam b e) = go (n-1) (b:bs) e
     go _ _  _         = pprPanic "collectNBinders" $ int orig_n
 
--- | Takes a nested application expression and returns the the function
+-- | Takes a nested application expression and returns the function
 -- being applied and the arguments to which it is applied
 collectArgs :: Expr b -> (Expr b, [Arg b])
 collectArgs expr
@@ -2030,6 +2060,16 @@ collectArgs expr
     go (App f a) as = go f (a:as)
     go e         as = (e, as)
 
+-- | Attempt to remove the last N arguments of a function call.
+-- Strip off any ticks or coercions encountered along the way and any
+-- at the end.
+stripNArgs :: Word -> Expr a -> Maybe (Expr a)
+stripNArgs !n (Tick _ e) = stripNArgs n e
+stripNArgs n (Cast f _) = stripNArgs n f
+stripNArgs 0 e = Just e
+stripNArgs n (App f _) = stripNArgs (n - 1) f
+stripNArgs _ _ = Nothing
+
 -- | Like @collectArgs@, but also collects looks through floatable
 -- ticks if it means that we can find more arguments.
 collectArgsTicks :: (Tickish Id -> Bool) -> Expr b
@@ -2077,6 +2117,12 @@ isTyCoArg (Type {})     = True
 isTyCoArg (Coercion {}) = True
 isTyCoArg _             = False
 
+-- | Returns @True@ iff the expression is a 'Coercion'
+-- expression at its top level
+isCoArg :: Expr b -> Bool
+isCoArg (Coercion {}) = True
+isCoArg _             = False
+
 -- | Returns @True@ iff the expression is a 'Type' expression at its
 -- top level.  Note this does NOT include 'Coercion's.
 isTypeArg :: Expr b -> Bool
@@ -2124,7 +2170,7 @@ data AnnBind bndr annot
   = AnnNonRec bndr (AnnExpr bndr annot)
   | AnnRec    [(bndr, AnnExpr bndr annot)]
 
--- | Takes a nested application expression and returns the the function
+-- | Takes a nested application expression and returns the function
 -- being applied and the arguments to which it is applied
 collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
 collectAnnArgs expr
@@ -2158,16 +2204,16 @@ deAnnotate' (AnnTick tick body)   = Tick tick (deAnnotate body)
 
 deAnnotate' (AnnLet bind body)
   = Let (deAnnBind bind) (deAnnotate body)
-  where
-    deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
-    deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-
 deAnnotate' (AnnCase scrut v t alts)
   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 
 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 
+deAnnBind  :: AnnBind b annot -> Bind b
+deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
+deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
+
 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 collectAnnBndrs e
diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs
index 89ce692422..be5e6c1619 100644
--- a/compiler/coreSyn/CoreTidy.hs
+++ b/compiler/coreSyn/CoreTidy.hs
@@ -14,13 +14,15 @@ module CoreTidy (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreSeq ( seqUnfolding )
 import CoreArity
 import Id
 import IdInfo
 import Demand ( zapUsageEnvSig )
-import Type( tidyType, tidyTyCoVarBndr )
+import Type( tidyType, tidyVarBndr )
 import Coercion( tidyCo )
 import Var
 import VarEnv
@@ -128,7 +130,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
-  | isTyCoVar var = tidyTyCoVarBndr env var
+  | isTyCoVar var = tidyVarBndr env var
   | otherwise     = tidyIdBndr env var
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
@@ -157,9 +159,7 @@ tidyIdBndr env@(tidy_env, var_env) id
                                  `setOneShotInfo` oneShotInfo old_info
         old_info = idInfo id
         old_unf  = unfoldingInfo old_info
-        new_unf | isEvaldUnfolding old_unf = evaldUnfolding
-                | otherwise                = noUnfolding
-          -- See Note [Preserve evaluatedness]
+        new_unf  = zapUnfolding old_unf  -- See Note [Preserve evaluatedness]
     in
     ((tidy_env', var_env'), id')
    }
@@ -205,11 +205,10 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs)
                     `setInlinePragInfo` inlinePragInfo old_info
                     `setUnfoldingInfo`  new_unf
 
+        old_unf = unfoldingInfo old_info
         new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf
-                | isEvaldUnfolding  old_unf = evaldUnfolding
+                | otherwise                 = zapUnfolding old_unf
                                               -- See Note [Preserve evaluatedness]
-                | otherwise                 = noUnfolding
-        old_unf = unfoldingInfo old_info
     in
     ((tidy_env', var_env'), id') }
 
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index a104cd693f..adb399ea6f 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -42,6 +42,8 @@ module CoreUnfold (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import CoreSyn
 import PprCore          ()      -- Instances
@@ -63,8 +65,10 @@ import Bag
 import Util
 import Outputable
 import ForeignCall
+import Name
 
 import qualified Data.ByteString as BS
+import Data.List
 
 {-
 ************************************************************************
@@ -81,7 +85,7 @@ mkTopUnfolding dflags is_bottoming rhs
 mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding
 -- For implicit Ids, do a tiny bit of optimising first
 mkImplicitUnfolding dflags expr
-  = mkTopUnfolding dflags False (simpleOptExpr expr)
+  = mkTopUnfolding dflags False (simpleOptExpr dflags expr)
 
 -- Note [Top-level flag on inline rules]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -100,17 +104,17 @@ mkDFunUnfolding bndrs con ops
                   , df_args = map occurAnalyseExpr ops }
                   -- See Note [Occurrence analysis of unfoldings]
 
-mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
-mkWwInlineRule expr arity
+mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding
+mkWwInlineRule dflags expr arity
   = mkCoreUnfolding InlineStable True
-                   (simpleOptExpr expr)
+                   (simpleOptExpr dflags expr)
                    (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
                             , ug_boring_ok = boringCxtNotOk })
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr         -- Used for things that absolutely must be unfolded
   = mkCoreUnfolding InlineCompulsory True
-                    (simpleOptExpr expr)
+                    (simpleOptExpr unsafeGlobalDynFlags expr)
                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter
                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
 
@@ -122,7 +126,7 @@ mkWorkerUnfolding dflags work_fn
   | isStableSource src
   = mkCoreUnfolding src top_lvl new_tmpl guidance
   where
-    new_tmpl = simpleOptExpr (work_fn tmpl)
+    new_tmpl = simpleOptExpr dflags (work_fn tmpl)
     guidance = calcUnfoldingGuidance dflags False new_tmpl
 
 mkWorkerUnfolding _ _ _ = noUnfolding
@@ -137,7 +141,7 @@ mkInlineUnfolding expr
                     True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
-    expr' = simpleOptExpr expr
+    expr' = simpleOptExpr unsafeGlobalDynFlags expr
     guide = UnfWhen { ug_arity = manifestArity expr'
                     , ug_unsat_ok = unSaturatedOk
                     , ug_boring_ok = boring_ok }
@@ -151,24 +155,28 @@ mkInlineUnfoldingWithArity arity expr
                     True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
-    expr' = simpleOptExpr expr
+    expr' = simpleOptExpr unsafeGlobalDynFlags expr
     guide = UnfWhen { ug_arity = arity
                     , ug_unsat_ok = needSaturated
                     , ug_boring_ok = boring_ok }
-    boring_ok = inlineBoringOk expr'
+    -- See Note [INLINE pragmas and boring contexts] as to why we need to look
+    -- at the arity here.
+    boring_ok | arity == 0 = True
+              | otherwise  = inlineBoringOk expr'
 
 mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding
 mkInlinableUnfolding dflags expr
   = mkUnfolding dflags InlineStable False False expr'
   where
-    expr' = simpleOptExpr expr
+    expr' = simpleOptExpr dflags expr
 
-specUnfolding :: [Var] -> (CoreExpr -> CoreExpr) -> Arity -> Unfolding -> Unfolding
+specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
+              -> Unfolding -> Unfolding
 -- See Note [Specialising unfoldings]
 -- specUnfolding spec_bndrs spec_app arity_decrease unf
 --   = \spec_bndrs. spec_app( unf )
 --
-specUnfolding spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app arity_decrease
               df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
   = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )
     mkDFunUnfolding spec_bndrs con (map spec_arg args)
@@ -180,11 +188,11 @@ specUnfolding spec_bndrs spec_app arity_decrease
       --       \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>
       -- The ASSERT checks the value part of that
   where
-    spec_arg arg = simpleOptExpr (spec_app (mkLams old_bndrs arg))
+    spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg))
                    -- The beta-redexes created by spec_app will be
                    -- simplified away by simplOptExpr
 
-specUnfolding spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app arity_decrease
               (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
                              , uf_is_top = top_lvl
                              , uf_guidance = old_guidance })
@@ -195,13 +203,13 @@ specUnfolding spec_bndrs spec_app arity_decrease
  = let guidance = UnfWhen { ug_arity     = old_arity - arity_decrease
                           , ug_unsat_ok  = unsat_ok
                           , ug_boring_ok = boring_ok }
-       new_tmpl = simpleOptExpr (mkLams spec_bndrs (spec_app tmpl))
+       new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl))
                    -- The beta-redexes created by spec_app will be
                    -- simplified away by simplOptExpr
 
    in mkCoreUnfolding src top_lvl new_tmpl guidance
 
-specUnfolding _ _ _ _ = noUnfolding
+specUnfolding _ _ _ _ _ = noUnfolding
 
 {- Note [Specialising unfoldings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -231,6 +239,72 @@ specUnfolding to specialise its unfolding.  Some important points:
         we keep it (so the specialised thing too will always inline)
      if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
         (which arises from INLINABLE), we discard it
+
+Note [Honour INLINE on 0-ary bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   x = <expensive>
+   {-# INLINE x #-}
+
+   f y = ...x...
+
+The semantics of an INLINE pragma is
+
+  inline x at every call site, provided it is saturated;
+  that is, applied to at least as many arguments as appear
+  on the LHS of the Haskell source definition.
+
+(This soure-code-derived arity is stored in the `ug_arity` field of
+the `UnfoldingGuidance`.)
+
+In the example, x's ug_arity is 0, so we should inline it at every use
+site.  It's rare to have such an INLINE pragma (usually INLINE Is on
+functions), but it's occasionally very important (Trac #15578, #15519).
+In #15519 we had something like
+   x = case (g a b) of I# r -> T r
+   {-# INLINE x #-}
+   f y = ...(h x)....
+
+where h is strict.  So we got
+   f y = ...(case g a b of I# r -> h (T r))...
+
+and that in turn allowed SpecConstr to ramp up performance.
+
+How do we deliver on this?  By adjusting the ug_boring_ok
+flag in mkInlineUnfoldingWithArity; see
+Note [INLINE pragmas and boring contexts]
+
+NB: there is a real risk that full laziness will float it right back
+out again. Consider again
+  x = factorial 200
+  {-# INLINE x #-}
+  f y = ...x...
+
+After inlining we get
+  f y = ...(factorial 200)...
+
+but it's entirely possible that full laziness will do
+  lvl23 = factorial 200
+  f y = ...lvl23...
+
+That's a problem for another day.
+
+Note [INLINE pragmas and boring contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An INLINE pragma uses mkInlineUnfoldingWithArity to build the
+unfolding.  That sets the ug_boring_ok flag to False if the function
+is not tiny (inlineBorkingOK), so that even INLINE functions are not
+inlined in an utterly boring context.  E.g.
+     \x y. Just (f y x)
+Nothing is gained by inlining f here, even if it has an INLINE
+pragma.
+
+But for 0-ary bindings, we want to inline regardless; see
+Note [Honour INLINE on 0-ary bindings].
+
+I'm a bit worried that it's possible for the same kind of problem
+to arise for non-0-ary functions too, but let's wait and see.
 -}
 
 mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
@@ -696,7 +770,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
 -- Used by CoreUnfold.sizeExpr
-litSize (LitInteger {}) = 100   -- Note [Size of literal integers]
+litSize (LitNumber LitNumInteger _ _) = 100   -- Note [Size of literal integers]
+litSize (LitNumber LitNumNatural _ _) = 100
 litSize (MachStr str)   = 10 + 10 * ((BS.length str + 3) `div` 4)
         -- If size could be 0 then @f "x"@ might be too small
         -- [Sept03: make literal strings a bit bigger to avoid fruitless
@@ -943,7 +1018,7 @@ In a function application (f a b)
 Code for manipulating sizes
 -}
 
--- | The size of an candidate expression for unfolding
+-- | The size of a candidate expression for unfolding
 data ExprSize
     = TooBig
     | SizeIs { _es_size_is  :: {-# UNPACK #-} !Int -- ^ Size found
@@ -1147,51 +1222,55 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
       -- idUnfolding checks for loop-breakers, returning NoUnfolding
       -- Things with an INLINE pragma may have an unfolding *and*
       -- be a loop breaker  (maybe the knot is not yet untied)
-        CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
+        CoreUnfolding { uf_tmpl = unf_template
                       , uf_is_work_free = is_wf
                       , uf_guidance = guidance, uf_expandable = is_exp }
           | active_unfolding -> tryUnfolding dflags id lone_variable
-                                    arg_infos cont_info unf_template is_top
+                                    arg_infos cont_info unf_template
                                     is_wf is_exp guidance
-          | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing
+          | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing
         NoUnfolding      -> Nothing
         BootUnfolding    -> Nothing
         OtherCon {}      -> Nothing
         DFunUnfolding {} -> Nothing     -- Never unfold a DFun
 
-traceInline :: DynFlags -> String -> SDoc -> a -> a
-traceInline dflags str doc result
+traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a
+traceInline dflags inline_id str doc result
+ | Just prefix <- inlineCheck dflags
+ =  if prefix `isPrefixOf` occNameString (getOccName inline_id)
+      then pprTrace str doc result
+      else result
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
  = pprTrace str doc result
  | otherwise
  = result
 
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
-             -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance
+             -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
              -> Maybe CoreExpr
 tryUnfolding dflags id lone_variable
-             arg_infos cont_info unf_template is_top
+             arg_infos cont_info unf_template
              is_wf is_exp guidance
  = case guidance of
-     UnfNever -> traceInline dflags str (text "UnfNever") Nothing
+     UnfNever -> traceInline dflags id str (text "UnfNever") Nothing
 
      UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
         | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)
                 -- See Note [INLINE for small functions (3)]
-        -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)
         | otherwise
-        -> traceInline dflags str (mk_doc some_benefit empty False) Nothing
+        -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing
         where
           some_benefit = calc_some_benefit uf_arity
           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
 
      UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
         | ufVeryAggressive dflags
-        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | is_wf && some_benefit && small_enough
-        -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template)
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | otherwise
-        -> traceInline dflags str (mk_doc some_benefit extra_doc False) Nothing
+        -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing
         where
           some_benefit = calc_some_benefit (length arg_discounts)
           extra_doc = text "discounted size =" <+> int discounted_size
@@ -1239,13 +1318,13 @@ tryUnfolding dflags id lone_variable
           = True
           | otherwise
           = case cont_info of
-              CaseCtxt   -> not (lone_variable && is_wf)  -- Note [Lone variables]
-              ValAppCtxt -> True                              -- Note [Cast then apply]
+              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone variables]
+              ValAppCtxt -> True                           -- Note [Cast then apply]
               RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy contexts]
-              DiscArgCtxt -> uf_arity > 0  --
+              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]
               RhsCtxt     -> uf_arity > 0  --
-              _           -> not is_top && uf_arity > 0   -- Note [Nested functions]
-                                                      -- Note [Inlining in ArgCtxt]
+              _other      -> False         -- See Note [Nested functions]
+
 
 {-
 Note [Unfold into lazy contexts], Note [RHS of lets]
@@ -1315,18 +1394,17 @@ However for worker/wrapper it may be worth inlining even if the
 arity is not satisfied (as we do in the CoreUnfolding case) so we don't
 require saturation.
 
-
 Note [Nested functions]
 ~~~~~~~~~~~~~~~~~~~~~~~
-If a function has a nested defn we also record some-benefit, on the
-grounds that we are often able to eliminate the binding, and hence the
-allocation, for the function altogether; this is good for join points.
-But this only makes sense for *functions*; inlining a constructor
-doesn't help allocation unless the result is scrutinised.  UNLESS the
-constructor occurs just once, albeit possibly in multiple case
-branches.  Then inlining it doesn't increase allocation, but it does
-increase the chance that the constructor won't be allocated at all in
-the branches that don't use it.
+At one time we treated a call of a non-top-level function as
+"interesting" (regardless of how boring the context) in the hope
+that inlining it would eliminate the binding, and its allocation.
+Specifically, in the default case of interesting_call we had
+   _other -> not is_top && uf_arity > 0
+
+But actually postInlineUnconditionally does some of this and overall
+it makes virtually no difference to nofib.  So I simplified away this
+special case
 
 Note [Cast then apply]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -1386,9 +1464,10 @@ because the latter is strict.
         s = "foo"
         f = \x -> ...(error s)...
 
-Fundamentally such contexts should not encourage inlining because the
+Fundamentally such contexts should not encourage inlining because, provided
+the RHS is "expandable" (see Note [exprIsExpandable] in CoreUtils) the
 context can ``see'' the unfolding of the variable (e.g. case or a
-RULE) so there's no gain.  If the thing is bound to a value.
+RULE) so there's no gain.
 
 However, watch out:
 
@@ -1439,6 +1518,8 @@ This kind of thing can occur if you have
         foo = let x = e in (x,x)
 
 which Roman did.
+
+
 -}
 
 computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 540a36e0a1..453d984ec4 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -29,7 +29,8 @@ module CoreUtils (
         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
         exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
-        exprIsLiteralString, exprIsTopLevelBindable,
+        exprIsTickedString, exprIsTickedString_maybe,
+        exprIsTopLevelBindable,
         altsAreExhaustive,
 
         -- * Equality
@@ -58,6 +59,8 @@ module CoreUtils (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import PrelNames ( makeStaticName )
 import PprCore
@@ -72,8 +75,9 @@ import DataCon
 import PrimOp
 import Id
 import IdInfo
+import PrelNames( absentErrorIdKey )
 import Type
-import TyCoRep( TyBinder(..) )
+import TyCoRep( TyCoBinder(..), TyBinder )
 import Coercion
 import TyCon
 import Unique
@@ -83,14 +87,17 @@ import DynFlags
 import FastString
 import Maybes
 import ListSetOps       ( minusList )
-import BasicTypes       ( Arity )
+import BasicTypes       ( Arity, isConLike )
 import Platform
 import Util
 import Pair
+import Data.ByteString     ( ByteString )
 import Data.Function       ( on )
 import Data.List
 import Data.Ord            ( comparing )
 import OrdList
+import qualified Data.Set as Set
+import UniqSet
 
 {-
 ************************************************************************
@@ -123,13 +130,13 @@ exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 
 coreAltType :: CoreAlt -> Type
 -- ^ Returns the type of the alternatives right hand side
-coreAltType (_,bs,rhs)
-  | any bad_binder bs = expandTypeSynonyms ty
-  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
+coreAltType alt@(_,bs,rhs)
+  = case occCheckExpand bs rhs_ty of
+      -- Note [Existential variables and silly type synonyms]
+      Just ty -> ty
+      Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty)
   where
-    ty           = exprType rhs
-    free_tvs     = tyCoVarsOfType ty
-    bad_binder b = b `elemVarSet` free_tvs
+    rhs_ty = exprType rhs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -179,7 +186,7 @@ isExprLevPoly = go
 Note [Type bindings]
 ~~~~~~~~~~~~~~~~~~~~
 Core does allow type bindings, although such bindings are
-not much used, except in the output of the desuguarer.
+not much used, except in the output of the desugarer.
 Example:
      let a = Int in (\x:a. x)
 Given this, exprType must be careful to substitute 'a' in the
@@ -250,7 +257,7 @@ applyTypeToArgs e op_ty args
 
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
-mkCast :: CoreExpr -> Coercion -> CoreExpr
+mkCast :: CoreExpr -> CoercionR -> CoreExpr
 mkCast e co
   | ASSERT2( coercionRole co == Representational
            , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")
@@ -474,8 +481,15 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- the simplifier deals with them perfectly well. See
 -- also 'MkCore.mkCoreLet'
 bindNonRec bndr rhs body
-  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
-  | otherwise                          = Let (NonRec bndr rhs) body
+  | isTyVar bndr                       = let_bind
+  | isCoVar bndr                       = if isCoArg rhs then let_bind
+    {- See Note [Binding coercions] -}                  else case_bind
+  | isJoinId bndr                      = let_bind
+  | needsCaseBinding (idType bndr) rhs = case_bind
+  | otherwise                          = let_bind
+  where
+    case_bind = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
+    let_bind  = Let (NonRec bndr rhs) body
 
 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
@@ -498,7 +512,12 @@ mkAltExpr (LitAlt lit) [] []
 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 
-{-
+{- Note [Binding coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider binding a CoVar, c = e.  Then, we must atisfy
+Note [CoreSyn type and coercion invariant] in CoreSyn,
+which allows only (Coercion co) on the RHS.
+
 ************************************************************************
 *                                                                      *
                Operations oer case alternatives
@@ -525,7 +544,7 @@ isDefaultAlt _               = False
 -- | Find the case alternative corresponding to a particular
 -- constructor: panics if no such constructor exists
 findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
-    -- A "Nothing" result *is* legitmiate
+    -- A "Nothing" result *is* legitimate
     -- See Note [Unreachable code]
 findAlt con alts
   = case alts of
@@ -607,8 +626,6 @@ filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (us
              --  2. The new alternatives, trimmed by
              --        a) remove imposs_cons
              --        b) remove constructors which can't match because of GADTs
-             --      and with the DEFAULT expanded to a DataAlt if there is exactly
-             --      remaining constructor that can match
              --
              -- NB: the final list of alternatives may be empty:
              -- This is a tricky corner case.  If the data type has no constructors,
@@ -626,22 +643,26 @@ filterAlts _tycon inst_tys imposs_cons alts
 
     trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default
 
-    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
+    imposs_cons_set = Set.fromList imposs_cons
+    imposs_deflt_cons =
+      imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons
          -- "imposs_deflt_cons" are handled
          --   EITHER by the context,
          --   OR by a non-DEFAULT branch in this case expression.
 
     impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
-    impossible_alt _ (con, _, _) | con `elem` imposs_cons = True
+    impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True
     impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
     impossible_alt _  _                         = False
 
-refineDefaultAlt :: [Unique] -> TyCon -> [Type]
-                 -> [AltCon]  -- Constructors that cannot match the DEFAULT (if any)
+-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.
+-- See Note [Refine Default Alts]
+refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders
+                 -> TyCon             -- ^ Type constructor of scrutinee's type
+                 -> [Type]            -- ^ Type arguments of scrutinee's type
+                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)
                  -> [CoreAlt]
-                 -> (Bool, [CoreAlt])
--- Refine the default alternative to a DataAlt,
--- if there is a unique way to do so
+                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'
 refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
   | (DEFAULT,_,rhs) : rest_alts <- all_alts
   , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.
@@ -649,8 +670,11 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
                                 --      case x of { DEFAULT -> e }
                                 -- and we don't want to fill in a default for them!
   , Just all_cons <- tyConDataCons_maybe tycon
-  , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type
-        impossible con   = con `elem` imposs_data_cons || dataConCannotMatch tys con
+  , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]
+                             -- We now know it's a data type, so we can use
+                             -- UniqSet rather than Set (more efficient)
+        impossible con   = con `elementOfUniqSet` imposs_data_cons
+                             || dataConCannotMatch tys con
   = case filterOut impossible all_cons of
        -- Eliminate the default alternative
        -- altogether if it can't match:
@@ -675,6 +699,93 @@ refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
   | otherwise      -- The common case
   = (False, all_alts)
 
+{- Note [Refine Default Alts]
+
+refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one
+possible value it could be.
+
+The simplest example being
+
+foo :: () -> ()
+foo x = case x of !_ -> ()
+
+rewrites to
+
+foo :: () -> ()
+foo x = case x of () -> ()
+
+There are two reasons in general why this is desirable.
+
+1. We can simplify inner expressions
+
+In this example we can eliminate the inner case by refining the outer case.
+If we don't refine it, we are left with both case expressions.
+
+```
+{-# LANGUAGE BangPatterns #-}
+module Test where
+
+mid x = x
+{-# NOINLINE mid #-}
+
+data Foo = Foo1 ()
+
+test :: Foo -> ()
+test x =
+  case x of
+    !_ -> mid (case x of
+                Foo1 x1 -> x1)
+
+```
+
+refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x
+becomes bound to `Foo ip1` so is inlined into the other case which
+causes the KnownBranch optimisation to kick in.
+
+
+2. combineIdenticalAlts does a better job
+
+Simon Jakobi also points out that that combineIdenticalAlts will do a better job
+if we refine the DEFAULT first.
+
+```
+data D = C0 | C1 | C2
+
+case e of
+   DEFAULT -> e0
+   C0 -> e1
+   C1 -> e1
+```
+
+When we apply combineIdenticalAlts to this expression, it can't
+combine the alts for C0 and C1, as we already have a default case.
+
+If we apply refineDefaultAlt first, we get
+
+```
+case e of
+  C0 -> e1
+  C1 -> e1
+  C2 -> e0
+```
+
+and combineIdenticalAlts can turn that into
+
+```
+case e of
+  DEFAULT -> e1
+  C2 -> e0
+```
+
+It isn't obvious that refineDefaultAlt does this but if you look at its one
+call site in SimplUtils then the `imposs_deflt_cons` argument is populated with
+constructors which are matched elsewhere.
+
+-}
+
+
+
+
 {- Note [Combine identical alternatives]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If several alternatives are identical, merge them into a single
@@ -844,6 +955,8 @@ it off at source.
 -}
 
 exprIsTrivial :: CoreExpr -> Bool
+-- If you modify this function, you may also
+-- need to modify getIdFromTrivialExpr
 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
 exprIsTrivial (Type _)         = True
 exprIsTrivial (Coercion _)     = True
@@ -873,20 +986,24 @@ if the variable actually refers to a literal; thus we use
 T12076lit for an example where this matters.
 -}
 
-getIdFromTrivialExpr :: CoreExpr -> Id
+getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
 getIdFromTrivialExpr e
     = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))
                 (getIdFromTrivialExpr_maybe e)
 
 getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
 -- See Note [getIdFromTrivialExpr]
-getIdFromTrivialExpr_maybe e = go e
-  where go (Var v) = Just v
-        go (App f t) | not (isRuntimeArg t) = go f
-        go (Tick t e) | not (tickishIsCode t) = go e
-        go (Cast e _) = go e
-        go (Lam b e) | not (isRuntimeVar b) = go e
-        go _ = Nothing
+-- Th equations for this should line up with those for exprIsTrivial
+getIdFromTrivialExpr_maybe e
+  = go e
+  where
+    go (App f t) | not (isRuntimeArg t)   = go f
+    go (Tick t e) | not (tickishIsCode t) = go e
+    go (Cast e _)                         = go e
+    go (Lam b e) | not (isRuntimeVar b)   = go e
+    go (Case e _ _ [])                    = go e
+    go (Var v) = Just v
+    go _       = Nothing
 
 {-
 exprIsBottom is a very cheap and cheerful function; it may return
@@ -1073,29 +1190,6 @@ Note that exprIsHNF does not imply exprIsCheap.  Eg
 This responds True to exprIsHNF (you can discard a seq), but
 False to exprIsCheap.
 
-Note [exprIsExpandable]
-~~~~~~~~~~~~~~~~~~~~~~~
-An expression is "expandable" if we are willing to dupicate it, if doing
-so might make a RULE or case-of-constructor fire.  Mainly this means
-data-constructor applications, but it's a bit more generous than exprIsCheap
-because it is true of "CONLIKE" Ids: see Note [CONLIKE pragma] in BasicTypes.
-
-It is used to set the uf_expandable field of an Unfolding, and that
-in turn is used
-  * In RULE matching
-  * In exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe
-
-But take care: exprIsExpandable should /not/ be true of primops.  I
-found this in test T5623a:
-    let q = /\a. Ptr a (a +# b)
-    in case q @ Float of Ptr v -> ...q...
-
-q's inlining should not be expandable, else exprIsConApp_maybe will
-say that (q @ Float) expands to (Ptr a (a +# b)), and that will
-duplicate the (a +# b) primop, which we should not do lightly.
-(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
-
-
 Note [Arguments and let-bindings exprIsCheapX]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 What predicate should we apply to the argument of an application, or the
@@ -1121,16 +1215,12 @@ in this (which it previously was):
 -}
 
 --------------------
-exprIsCheap :: CoreExpr -> Bool
-exprIsCheap = exprIsCheapX isCheapApp
-
-exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]
-exprIsExpandable = exprIsCheapX isExpandableApp
-
 exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]
 exprIsWorkFree = exprIsCheapX isWorkFreeApp
 
---------------------
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap = exprIsCheapX isCheapApp
+
 exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
 exprIsCheapX ok_app e
   = ok e
@@ -1158,6 +1248,75 @@ exprIsCheapX ok_app e
       -- App, Let: see Note [Arguments and let-bindings exprIsCheapX]
 
 
+{- Note [exprIsExpandable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+An expression is "expandable" if we are willing to duplicate it, if doing
+so might make a RULE or case-of-constructor fire.  Consider
+   let x = (a,b)
+       y = build g
+   in ....(case x of (p,q) -> rhs)....(foldr k z y)....
+
+We don't inline 'x' or 'y' (see Note [Lone variables] in CoreUnfold),
+but we do want
+
+ * the case-expression to simplify
+   (via exprIsConApp_maybe, exprIsLiteral_maybe)
+
+ * the foldr/build RULE to fire
+   (by expanding the unfolding during rule matching)
+
+So we classify the unfolding of a let-binding as "expandable" (via the
+uf_expandable field) if we want to do this kind of on-the-fly
+expansion.  Specifically:
+
+* True of constructor applications (K a b)
+
+* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes.
+  (NB: exprIsCheap might not be true of this)
+
+* False of case-expressions.  If we have
+    let x = case ... in ...(case x of ...)...
+  we won't simplify.  We have to inline x.  See Trac #14688.
+
+* False of let-expressions (same reason); and in any case we
+  float lets out of an RHS if doing so will reveal an expandable
+  application (see SimplEnv.doFloatFromRhs).
+
+* Take care: exprIsExpandable should /not/ be true of primops.  I
+  found this in test T5623a:
+    let q = /\a. Ptr a (a +# b)
+    in case q @ Float of Ptr v -> ...q...
+
+  q's inlining should not be expandable, else exprIsConApp_maybe will
+  say that (q @ Float) expands to (Ptr a (a +# b)), and that will
+  duplicate the (a +# b) primop, which we should not do lightly.
+  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
+-}
+
+-------------------------------------
+exprIsExpandable :: CoreExpr -> Bool
+-- See Note [exprIsExpandable]
+exprIsExpandable e
+  = ok e
+  where
+    ok e = go 0 e
+
+    -- n is the number of value arguments
+    go n (Var v)                      = isExpandableApp v n
+    go _ (Lit {})                     = True
+    go _ (Type {})                    = True
+    go _ (Coercion {})                = True
+    go n (Cast e _)                   = go n e
+    go n (Tick t e) | tickishCounts t = False
+                    | otherwise       = go n e
+    go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e
+                    | otherwise       = go n e
+    go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e
+                    | otherwise       = go n f
+    go _ (Case {})                    = False
+    go _ (Let {})                     = False
+
+
 -------------------------------------
 type CheapAppFun = Id -> Arity -> Bool
   -- Is an application of this function to n *value* args
@@ -1168,22 +1327,11 @@ type CheapAppFun = Id -> Arity -> Bool
   --    isCheapApp
   --    isExpandableApp
 
-  -- NB: isCheapApp and isExpandableApp are called from outside
-  --     this module, so don't be tempted to move the notRedex
-  --     stuff into the call site in exprIsCheapX, and remove it
-  --     from the CheapAppFun implementations
-
-
-notRedex :: CheapAppFun
-notRedex fn n_val_args
-  =  n_val_args == 0           -- No value args
-  || n_val_args < idArity fn   -- Partial application
-  || isBottomingId fn   -- OK to duplicate calls to bottom;
-                        -- it certainly doesn't need to be shared!
-
 isWorkFreeApp :: CheapAppFun
 isWorkFreeApp fn n_val_args
-  | notRedex fn n_val_args
+  | n_val_args == 0           -- No value args
+  = True
+  | n_val_args < idArity fn   -- Partial application
   = True
   | otherwise
   = case idDetails fn of
@@ -1192,11 +1340,11 @@ isWorkFreeApp fn n_val_args
 
 isCheapApp :: CheapAppFun
 isCheapApp fn n_val_args
-  | notRedex fn n_val_args
-  = True
+  | isWorkFreeApp fn n_val_args = True
+  | isBottomingId fn            = True  -- See Note [isCheapApp: bottoming functions]
   | otherwise
   = case idDetails fn of
-      DataConWorkId {} -> True
+      DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp
       RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]
       ClassOpId {}     -> n_val_args == 1
       PrimOpId op      -> primOpIsCheap op
@@ -1208,21 +1356,24 @@ isCheapApp fn n_val_args
 
 isExpandableApp :: CheapAppFun
 isExpandableApp fn n_val_args
-  | notRedex fn n_val_args
-  = True
-  | isConLikeId fn
-  = True
+  | isWorkFreeApp fn n_val_args = True
   | otherwise
   = case idDetails fn of
-      DataConWorkId {} -> True
+      DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp
       RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]
       ClassOpId {}     -> n_val_args == 1
       PrimOpId {}      -> False
-      _                -> all_pred_args n_val_args (idType fn)
+      _ | isBottomingId fn               -> False
+          -- See Note [isExpandableApp: bottoming functions]
+        | isConLike (idRuleMatchInfo fn) -> True
+        | all_args_are_preds             -> True
+        | otherwise                      -> False
 
   where
-  -- See if all the arguments are PredTys (implicit params or classes)
-  -- If so we'll regard it as expandable; see Note [Expandable overloadings]
+     -- See if all the arguments are PredTys (implicit params or classes)
+     -- If so we'll regard it as expandable; see Note [Expandable overloadings]
+     all_args_are_preds = all_pred_args n_val_args (idType fn)
+
      all_pred_args n_val_args ty
        | n_val_args == 0
        = True
@@ -1235,7 +1386,35 @@ isExpandableApp fn n_val_args
        | otherwise
        = False
 
-{- Note [Record selection]
+{- Note [isCheapApp: bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I'm not sure why we have a special case for bottoming
+functions in isCheapApp.  Maybe we don't need it.
+
+Note [isExpandableApp: bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important that isExpandableApp does not respond True to bottoming
+functions.  Recall  undefined :: HasCallStack => a
+Suppose isExpandableApp responded True to (undefined d), and we had:
+
+  x = undefined <dict-expr>
+
+Then Simplify.prepareRhs would ANF the RHS:
+
+  d = <dict-expr>
+  x = undefined d
+
+This is already bad: we gain nothing from having x bound to (undefined
+var), unlike the case for data constructors.  Worse, we get the
+simplifier loop described in OccurAnal Note [Cascading inlines].
+Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will
+certainly_inline; so we end up inlining d right back into x; but in
+the end x doesn't inline because it is bottom (preInlineUnconditionally);
+so the process repeats.. We could elaborate the certainly_inline logic
+some more, but it's better just to treat bottoming bindings as
+non-expandable, because ANFing them is a bad idea in the first place.
+
+Note [Record selection]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 I'm experimenting with making record selection
 look cheap, so we will substitute it inside a
@@ -1308,18 +1487,22 @@ it's applied only to dictionaries.
 --
 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 -- side effects, and can't diverge or raise an exception.
-exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
+
+exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
 exprOkForSpeculation = expr_ok primOpOkForSpeculation
 exprOkForSideEffects = expr_ok primOpOkForSideEffects
-  -- Polymorphic in binder type
-  -- There is one call at a non-Id binder type, in SetLevels
 
-expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
+expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
 expr_ok _ (Lit _)      = True
 expr_ok _ (Type _)     = True
 expr_ok _ (Coercion _) = True
-expr_ok primop_ok (Var v)      = app_ok primop_ok v []
-expr_ok primop_ok (Cast e _)   = expr_ok primop_ok e
+
+expr_ok primop_ok (Var v)    = app_ok primop_ok v []
+expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
+expr_ok primop_ok (Lam b e)
+                 | isTyVar b = expr_ok primop_ok  e
+                 | otherwise = True
+
 
 -- Tick annotations that *tick* cannot be speculated, because these
 -- are meant to identify whether or not (and how often) the particular
@@ -1328,10 +1511,18 @@ expr_ok primop_ok (Tick tickish e)
    | tickishCounts tickish = False
    | otherwise             = expr_ok primop_ok e
 
-expr_ok primop_ok (Case e _ _ alts)
-  =  expr_ok primop_ok e  -- Note [exprOkForSpeculation: case expressions]
+expr_ok _ (Let {}) = False
+  -- Lets can be stacked deeply, so just give up.
+  -- In any case, the argument of exprOkForSpeculation is
+  -- usually in a strict context, so any lets will have been
+  -- floated away.
+
+expr_ok primop_ok (Case scrut bndr _ alts)
+  =  -- See Note [exprOkForSpeculation: case expressions]
+     expr_ok primop_ok scrut
+  && isUnliftedType (idType bndr)
   && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
-  && altsAreExhaustive alts     -- Note [Exhaustive alts]
+  && altsAreExhaustive alts
 
 expr_ok primop_ok other_expr
   = case collectArgs other_expr of
@@ -1340,7 +1531,7 @@ expr_ok primop_ok other_expr
         _            -> False
 
 -----------------------------
-app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
+app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
 app_ok primop_ok fun args
   = case idDetails fun of
       DFunId new_type ->  not new_type
@@ -1363,8 +1554,11 @@ app_ok primop_ok fun args
               -- Often there is a literal divisor, and this
               -- can get rid of a thunk in an inner loop
 
+        | SeqOp <- op    -- See Note [seq# and expr_ok]
+        -> all (expr_ok primop_ok) args
+
         | otherwise
-        -> primop_ok op     -- Check the primop itself
+        -> primop_ok op  -- Check the primop itself
         && and (zipWith arg_ok arg_tys args)  -- Check the arguments
 
       _other -> isUnliftedType (idType fun)          -- c.f. the Var case of exprIsHNF
@@ -1376,7 +1570,7 @@ app_ok primop_ok fun args
   where
     (arg_tys, _) = splitPiTys (idType fun)
 
-    arg_ok :: TyBinder -> Expr b -> Bool
+    arg_ok :: TyBinder -> CoreExpr -> Bool
     arg_ok (Named _) _ = True   -- A type argument
     arg_ok (Anon ty) arg        -- A term argument
        | isUnliftedType ty = expr_ok primop_ok arg
@@ -1411,22 +1605,72 @@ isDivOp FloatDivOp       = True
 isDivOp DoubleDivOp      = True
 isDivOp _                = False
 
-{-
-Note [exprOkForSpeculation: case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's always sound for exprOkForSpeculation to return False, and we
-don't want it to take too long, so it bales out on complicated-looking
-terms.  Notably lets, which can be stacked very deeply; and in any
-case the argument of exprOkForSpeculation is usually in a strict context,
-so any lets will have been floated away.
-
-However, we keep going on case-expressions.  An example like this one
-showed up in DPH code (Trac #3717):
+{- Note [exprOkForSpeculation: case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprOkForSpeculation accepts very special case expressions.
+Reason: (a ==# b) is ok-for-speculation, but the litEq rules
+in PrelRules convert it (a ==# 3#) to
+   case a of { DEAFULT -> 0#; 3# -> 1# }
+for excellent reasons described in
+  PrelRules Note [The litEq rule: converting equality to case].
+So, annoyingly, we want that case expression to be
+ok-for-speculation too. Bother.
+
+But we restrict it sharply:
+
+* We restrict it to unlifted scrutinees. Consider this:
+     case x of y {
+       DEFAULT -> ... (let v::Int# = case y of { True  -> e1
+                                               ; False -> e2 }
+                       in ...) ...
+
+  Does the RHS of v satisfy the let/app invariant?  Previously we said
+  yes, on the grounds that y is evaluated.  But the binder-swap done
+  by SetLevels would transform the inner alternative to
+     DEFAULT -> ... (let v::Int# = case x of { ... }
+                     in ...) ....
+  which does /not/ satisfy the let/app invariant, because x is
+  not evaluated. See Note [Binder-swap during float-out]
+  in SetLevels.  To avoid this awkwardness it seems simpler
+  to stick to unlifted scrutinees where the issue does not
+  arise.
+
+* We restrict it to exhaustive alternatives. A non-exhaustive
+  case manifestly isn't ok-for-speculation. Consider
+    case e of x { DEAFULT ->
+      ...(case x of y
+            A -> ...
+            _ -> ...(case (case x of { B -> p; C -> p }) of
+                       I# r -> blah)...
+  If SetLevesls considers the inner nested case as ok-for-speculation
+  it can do case-floating (see Note [Floating cases] in SetLevels).
+  So we'd float to:
+    case e of x { DEAFULT ->
+    case (case x of { B -> p; C -> p }) of I# r ->
+    ...(case x of y
+            A -> ...
+            _ -> ...blah...)...
+  which is utterly bogus (seg fault); see Trac #5453.
+
+  Similarly, this is a valid program (albeit a slightly dodgy one)
+    let v = case x of { B -> ...; C -> ... }
+    in case x of
+         A -> ...
+         _ ->  ...v...v....
+  Should v be considered ok-for-speculation?  Its scrutinee may be
+  evaluated, but the alternatives are incomplete so we should not
+  evaluate it strictly.
+
+  Now, all this is for lifted types, but it'd be the same for any
+  finite unlifted type. We don't have many of them, but we might
+  add unlifted algebraic types in due course.
+
+----- Historical note: Trac #3717: --------
     foo :: Int -> Int
     foo 0 = 0
     foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
 
-If exprOkForSpeculation doesn't look through case expressions, you get this:
+In earlier GHCs, we got this:
     T.$wfoo =
       \ (ww :: GHC.Prim.Int#) ->
         case ww of ds {
@@ -1435,31 +1679,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
                           GHC.Types.True -> lvl})
                        of _ { __DEFAULT ->
                        T.$wfoo (GHC.Prim.-# ds_XkE 1) };
-          0 -> 0
-        }
-
-The inner case is redundant, and should be nuked.
-
-Note [Exhaustive alts]
-~~~~~~~~~~~~~~~~~~~~~~
-We might have something like
-  case x of {
-    A -> ...
-    _ -> ...(case x of { B -> ...; C -> ... })...
-Here, the inner case is fine, because the A alternative
-can't happen, but it's not ok to float the inner case outside
-the outer one (even if we know x is evaluated outside), because
-then it would be non-exhaustive. See Trac #5453.
-
-Similarly, this is a valid program (albeit a slightly dodgy one)
-   let v = case x of { B -> ...; C -> ... }
-   in case x of
-         A -> ...
-         _ ->  ...v...v....
-But we don't want to speculate the v binding.
+          0 -> 0 }
 
-One could try to be clever, but the easy fix is simpy to regard
-a non-exhaustive case as *not* okForSpeculation.
+Before join-points etc we could only get rid of two cases (which are
+redundant) by recognising that th e(case <# ds 5 of { ... }) is
+ok-for-speculation, even though it has /lifted/ type.  But now join
+points do the job nicely.
+------- End of historical note ------------
 
 
 Note [Primops with lifted arguments]
@@ -1471,8 +1697,8 @@ evaluate them.  Indeed, in general primops are, well, primitive
 and do not perform evaluation.
 
 There is one primop, dataToTag#, which does /require/ a lifted
-argument to be evaluted.  To ensure this, CorePrep adds an
-eval if it can't see the the argument is definitely evaluated
+argument to be evaluated.  To ensure this, CorePrep adds an
+eval if it can't see the argument is definitely evaluated
 (see [dataToTag magic] in CorePrep).
 
 We make no attempt to guarantee that dataToTag#'s argument is
@@ -1489,6 +1715,25 @@ See also Note [dataToTag#] in primops.txt.pp.
 
 Bottom line:
   * in exprOkForSpeculation we simply ignore all lifted arguments.
+  * except see Note [seq# and expr_ok] for an exception
+
+
+Note [seq# and expr_ok]
+~~~~~~~~~~~~~~~~~~~~~~~
+Recall that
+   seq# :: forall a s . a -> State# s -> (# State# s, a #)
+must always evaluate its first argument.  So it's really a
+counter-example to Note [Primops with lifted arguments]. In
+the case of seq# we must check the argument to seq#.  Remember
+item (d) of the specification of exprOkForSpeculation:
+
+  -- Precisely, it returns @True@ iff:
+  --  a) The expression guarantees to terminate,
+         ...
+  --  d) without throwing a Haskell exception
+
+The lack of this special case caused Trac #5129 to go bad again.
+See comment:24 and following
 
 
 ************************************************************************
@@ -1546,9 +1791,9 @@ exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
 exprIsHNFlike is_con is_con_unf = is_hnf_like
   where
     is_hnf_like (Var v) -- NB: There are no value args at this point
-      =  is_con v       -- Catches nullary constructors,
-                        --      so that [] and () are values, for example
-      || idArity v > 0  -- Catches (e.g.) primops that don't have unfoldings
+      =  id_app_is_value v 0 -- Catches nullary constructors,
+                             --      so that [] and () are values, for example
+                             -- and (e.g.) primops that don't have unfoldings
       || is_con_unf (idUnfolding v)
         -- Check the thing's unfolding; it might be bound to a value
         -- We don't look through loop breakers here, which is a bit conservative
@@ -1561,7 +1806,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
     is_hnf_like (Coercion _)     = True       -- Same for coercions
     is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
     is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
-                                      && is_hnf_like e
+                                   && is_hnf_like e
                                       -- See Note [exprIsHNF Tick]
     is_hnf_like (Cast e _)       = is_hnf_like e
     is_hnf_like (App e a)
@@ -1573,9 +1818,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
     -- There is at least one value argument
     -- 'n' is number of value args to which the expression is applied
     app_is_value :: CoreExpr -> Int -> Bool
-    app_is_value (Var fun) n_val_args
-      = idArity fun > n_val_args    -- Under-applied function
-        || is_con fun               --  or constructor-like
+    app_is_value (Var f)    nva = id_app_is_value f nva
     app_is_value (Tick _ f) nva = app_is_value f nva
     app_is_value (Cast f _) nva = app_is_value f nva
     app_is_value (App f a)  nva
@@ -1583,6 +1826,13 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
       | otherwise               = app_is_value f nva
     app_is_value _ _ = False
 
+    id_app_is_value id n_val_args
+       = is_con id
+       || idArity id > n_val_args
+       || id `hasKey` absentErrorIdKey  -- See Note [aBSENT_ERROR_ID] in MkCore
+                      -- absentError behaves like an honorary data constructor
+
+
 {-
 Note [exprIsHNF Tick]
 
@@ -1602,13 +1852,28 @@ don't want to discard a seq on it.
 exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
 -- See Note [CoreSyn top-level string literals]
 -- Precondition: exprType expr = ty
+-- Top-level literal strings can't even be wrapped in ticks
+--   see Note [CoreSyn top-level string literals] in CoreSyn
 exprIsTopLevelBindable expr ty
-  = exprIsLiteralString expr
-  || not (isUnliftedType ty)
-
-exprIsLiteralString :: CoreExpr -> Bool
-exprIsLiteralString (Lit (MachStr _)) = True
-exprIsLiteralString _ = False
+  = not (isUnliftedType ty)
+  || exprIsTickedString expr
+
+-- | Check if the expression is zero or more Ticks wrapped around a literal
+-- string.
+exprIsTickedString :: CoreExpr -> Bool
+exprIsTickedString = isJust . exprIsTickedString_maybe
+
+-- | Extract a literal string from an expression that is zero or more Ticks
+-- wrapped around a literal string. Returns Nothing if the expression has a
+-- different shape.
+-- Used to "look through" Ticks in places that need to handle literal strings.
+exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
+exprIsTickedString_maybe (Lit (MachStr bs)) = Just bs
+exprIsTickedString_maybe (Tick t e)
+  -- we don't tick literals with CostCentre ticks, compare to mkTick
+  | tickishPlace t == PlaceCostCentre = Nothing
+  | otherwise = exprIsTickedString_maybe e
+exprIsTickedString_maybe _ = Nothing
 
 {-
 ************************************************************************
@@ -1620,8 +1885,8 @@ exprIsLiteralString _ = False
 These InstPat functions go here to avoid circularity between DataCon and Id
 -}
 
-dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
-dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
+dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id])
 
 dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))
 dataConRepFSInstPat = dataConInstPat
@@ -1630,7 +1895,7 @@ dataConInstPat :: [FastString]          -- A long enough list of FSs to use for
                -> [Unique]              -- An equally long list of uniques, at least one for each binder
                -> DataCon
                -> [Type]                -- Types to instantiate the universally quantified tyvars
-               -> ([TyVar], [Id])       -- Return instantiated variables
+               -> ([TyCoVar], [Id])     -- Return instantiated variables
 -- dataConInstPat arg_fun fss us con inst_tys returns a tuple
 -- (ex_tvs, arg_ids),
 --
@@ -1663,7 +1928,7 @@ dataConInstPat fss uniqs con inst_tys
     (ex_bndrs, arg_ids)
   where
     univ_tvs = dataConUnivTyVars con
-    ex_tvs   = dataConExTyVars con
+    ex_tvs   = dataConExTyCoVars con
     arg_tys  = dataConRepArgTys con
     arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys
     n_ex = length ex_tvs
@@ -1679,13 +1944,16 @@ dataConInstPat fss uniqs con inst_tys
     (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
                                        (zip3 ex_tvs ex_fss ex_uniqs)
 
-    mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar)
-    mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubstWithClone subst tv
+    mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar)
+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv
                                        new_tv
                                      , new_tv)
       where
-        new_tv = mkTyVar (mkSysTvName uniq fs) kind
-        kind   = Type.substTyUnchecked subst (tyVarKind tv)
+        new_tv | isTyVar tv
+               = mkTyVar (mkSysTvName uniq fs) kind
+               | otherwise
+               = mkCoVar (mkSystemVarName uniq fs) kind
+        kind   = Type.substTyUnchecked subst (varType tv)
 
       -- Make value vars, instantiating types
     arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
@@ -2162,12 +2430,13 @@ and 'execute' it rather than allocating it statically.
 -- | This function is called only on *top-level* right-hand sides.
 -- Returns @True@ if the RHS can be allocated statically in the output,
 -- with no thunks involved at all.
-rhsIsStatic :: Platform
-            -> (Name -> Bool)         -- Which names are dynamic
-            -> (Integer -> CoreExpr)  -- Desugaring for integer literals (disgusting)
-                                      -- C.f. Note [Disgusting computation of CafRefs]
-                                      --      in TidyPgm
-            -> CoreExpr -> Bool
+rhsIsStatic
+   :: Platform
+   -> (Name -> Bool)         -- Which names are dynamic
+   -> (LitNumType -> Integer -> Maybe CoreExpr)
+      -- Desugaring for some literals (disgusting)
+      -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm
+   -> CoreExpr -> Bool
 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
 -- update flag on it and (iii) in DsExpr to decide how to expand
@@ -2222,7 +2491,7 @@ rhsIsStatic :: Platform
 --
 --    c) don't look through unfolding of f in (f x).
 
-rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
+rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs
   where
   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
             -> CoreExpr -> Bool
@@ -2232,7 +2501,9 @@ rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
                                               && is_static in_arg e
   is_static in_arg (Cast e _)             = is_static in_arg e
   is_static _      (Coercion {})          = True   -- Behaves just like a literal
-  is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
+  is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of
+    Just e  -> is_static in_arg e
+    Nothing -> True
   is_static _      (Lit (MachLabel {}))   = False
   is_static _      (Lit _)                = True
         -- A MachLabel (foreign import "&foo") in an argument
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 5a29994d0e..a425ad249e 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -42,15 +42,17 @@ module MkCore (
         mkNothingExpr, mkJustExpr,
 
         -- * Error Ids
-        mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
-        rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
+        mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
+        rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
         pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
-        tYPE_ERROR_ID,
+        tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Id
 import Var      ( EvVar, setTyVarUnique )
 
@@ -63,13 +65,11 @@ import TysWiredIn
 import PrelNames
 
 import HsUtils          ( mkChunkified, chunkify )
-import TcType           ( mkSpecSigmaTy )
 import Type
 import Coercion         ( isCoVar )
 import TysPrim
 import DataCon          ( DataCon, dataConWorkId )
-import IdInfo           ( vanillaIdInfo, setStrictnessInfo,
-                          setArityInfo )
+import IdInfo
 import Demand
 import Name      hiding ( varName )
 import Outputable
@@ -81,6 +81,7 @@ import DynFlags
 import Data.List
 
 import Data.Char        ( ord )
+import Control.Monad.Fail ( MonadFail )
 
 infixl 4 `mkCoreApp`, `mkCoreApps`
 
@@ -106,9 +107,7 @@ sortQuantVars vs = sorted_tcvs ++ ids
 -- appropriate (see "CoreSyn#let_app_invariant")
 mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
 mkCoreLet (NonRec bndr rhs) body        -- See Note [CoreSyn let/app invariant]
-  | needsCaseBinding (idType bndr) rhs
-  , not (isJoinId bndr)
-  = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
+  = bindNonRec bndr rhs body
 mkCoreLet bind body
   = Let bind body
 
@@ -118,34 +117,43 @@ mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
 mkCoreLets binds body = foldr mkCoreLet body binds
 
 -- | Construct an expression which represents the application of one expression
+-- paired with its type to an argument. The result is paired with its type. This
+-- function is not exported and used in the definition of 'mkCoreApp' and
+-- 'mkCoreApps'.
+-- Respects the let/app invariant by building a case expression where necessary
+--   See CoreSyn Note [CoreSyn let/app invariant]
+mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
+mkCoreAppTyped _ (fun, fun_ty) (Type ty)
+  = (App fun (Type ty), piResultTy fun_ty ty)
+mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
+  = (App fun (Coercion co), res_ty)
+  where
+    (_, res_ty) = splitFunTy fun_ty
+mkCoreAppTyped d (fun, fun_ty) arg
+  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
+    (mk_val_app fun arg arg_ty res_ty, res_ty)
+  where
+    (arg_ty, res_ty) = splitFunTy fun_ty
+
+-- | Construct an expression which represents the application of one expression
 -- to the other
-mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
 -- Respects the let/app invariant by building a case expression where necessary
 --   See CoreSyn Note [CoreSyn let/app invariant]
-mkCoreApp _ fun (Type ty)     = App fun (Type ty)
-mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
-mkCoreApp d fun arg           = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
-                                mk_val_app fun arg arg_ty res_ty
-                              where
-                                fun_ty = exprType fun
-                                (arg_ty, res_ty) = splitFunTy fun_ty
+mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreApp s fun arg
+  = fst $ mkCoreAppTyped s (fun, exprType fun) arg
 
 -- | Construct an expression which represents the application of a number of
 -- expressions to another. The leftmost expression in the list is applied first
 -- Respects the let/app invariant by building a case expression where necessary
 --   See CoreSyn Note [CoreSyn let/app invariant]
 mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
--- Slightly more efficient version of (foldl mkCoreApp)
-mkCoreApps orig_fun orig_args
-  = go orig_fun (exprType orig_fun) orig_args
+mkCoreApps fun args
+  = fst $
+    foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
   where
-    go fun _      []               = fun
-    go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (piResultTy fun_ty ty) args
-    go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun
-                                                              $$ ppr orig_args )
-                                     go (mk_val_app fun arg arg_ty res_ty) res_ty args
-                                   where
-                                     (arg_ty, res_ty) = splitFunTy fun_ty
+    doc_string = ppr fun_ty $$ ppr fun $$ ppr args
+    fun_ty = exprType fun
 
 -- | Construct an expression which represents the application of a number of
 -- expressions to that of a data constructor expression. The leftmost expression
@@ -171,7 +179,7 @@ mk_val_app fun arg arg_ty res_ty
         --
         -- This is Dangerous.  But this is the only place we play this
         -- game, mk_val_app returns an expression that does not have
-        -- have a free wild-id.  So the only thing that can go wrong
+        -- a free wild-id.  So the only thing that can go wrong
         -- is if you take apart this case expression, and pass a
         -- fragment of it as the fun part of a 'mk_val_app'.
 
@@ -251,13 +259,9 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName
                      return (Lit (mkLitInteger i (mkTyConTy t)))
 
 -- | Create a 'CoreExpr' which will evaluate to the given @Natural@
---
--- TODO: should we add LitNatural to Core?
-mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Natural
-mkNaturalExpr i = do iExpr <- mkIntegerExpr i
-                     fiExpr <- lookupId naturalFromIntegerName
-                     return (mkCoreApps (Var fiExpr) [iExpr])
-
+mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr
+mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
+                     return (Lit (mkLitNatural i (mkTyConTy t)))
 
 -- | Create a 'CoreExpr' which will evaluate to the given @Float@
 mkFloatExpr :: Float -> CoreExpr
@@ -328,7 +332,7 @@ We could do one of two things:
 * Flatten it out, so that
     mkCoreTup [e1] = e1
 
-* Built a one-tuple (see Note [One-tuples] in TysWiredIn)
+* Build a one-tuple (see Note [One-tuples] in TysWiredIn)
     mkCoreTup1 [e1] = Unit e1
   We use a suffix "1" to indicate this.
 
@@ -362,7 +366,7 @@ mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
 mkCoreUbxTup tys exps
   = ASSERT( tys `equalLength` exps)
     mkCoreConApps (tupleDataCon Unboxed (length tys))
-             (map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps)
+             (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
 
 -- | Make a core tuple of the given boxity
 mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
@@ -596,7 +600,7 @@ mkFoldrExpr elt_ty result_ty c n list = do
            `App` list)
 
 -- | Make a 'build' expression applied to a locally-bound worker function
-mkBuildExpr :: (MonadThings m, MonadUnique m)
+mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
             => Type                                     -- ^ Type of list elements to be built
             -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
                                                         -- of the binders for the build worker function, returns
@@ -651,7 +655,7 @@ mkRuntimeErrorApp
         -> CoreExpr
 
 mkRuntimeErrorApp err_id res_ty err_msg
-  = mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty)
+  = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
                         , Type res_ty, err_string ]
   where
     err_string = Lit (mkMachString err_msg)
@@ -686,7 +690,6 @@ templates, but we don't ever expect to generate code for it.
 errorIds :: [Id]
 errorIds
   = [ rUNTIME_ERROR_ID,
-      iRREFUT_PAT_ERROR_ID,
       nON_EXHAUSTIVE_GUARDS_ERROR_ID,
       nO_METHOD_BINDING_ERROR_ID,
       pAT_ERROR_ID,
@@ -697,14 +700,16 @@ errorIds
       ]
 
 recSelErrorName, runtimeErrorName, absentErrorName :: Name
-irrefutPatErrorName, recConErrorName, patErrorName :: Name
+recConErrorName, patErrorName :: Name
 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
 typeErrorName :: Name
+absentSumFieldErrorName :: Name
 
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
 absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID
+absentSumFieldErrorName = err_nm "absentSumFieldError"  absentSumFieldErrorIdKey
+                            aBSENT_SUM_FIELD_ERROR_ID
 runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
-irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
 recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
 patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
 typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
@@ -717,19 +722,46 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
 err_nm :: String -> Unique -> Id -> Name
 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
 
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
+rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
-tYPE_ERROR_ID, aBSENT_ERROR_ID :: Id
+tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
-iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
 rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
 pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
 nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-aBSENT_ERROR_ID                 = mkRuntimeErrorId absentErrorName
 tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
 
+-- Note [aBSENT_SUM_FIELD_ERROR_ID]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Absent argument error for unused unboxed sum fields are different than absent
+-- error used in dummy worker functions (see `mkAbsentErrorApp`):
+--
+-- - `absentSumFieldError` can't take arguments because it's used in unarise for
+--   unused pointer fields in unboxed sums, and applying an argument would
+--   require allocating a thunk.
+--
+-- - `absentSumFieldError` can't be CAFFY because that would mean making some
+--   non-CAFFY definitions that use unboxed sums CAFFY in unarise.
+--
+--   To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
+--   RtsStartup.c and mark it as non-CAFFY here.
+--
+-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
+--
+-- TODO: Remove stable pointer hack after fixing #9718.
+--       However, we should still be careful about not making things CAFFY just
+--       because they use unboxed sums. Unboxed objects are supposed to be
+--       efficient, and none of the other unboxed literals make things CAFFY.
+
+aBSENT_SUM_FIELD_ERROR_ID
+  = mkVanillaGlobalWithInfo absentSumFieldErrorName
+      (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
+      (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes
+                     `setArityInfo` 0
+                     `setCafInfo` NoCafRefs) -- #15038
+
 mkRuntimeErrorId :: Name -> Id
 -- Error function
 --   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
@@ -738,7 +770,7 @@ mkRuntimeErrorId :: Name -> Id
 -- The Addr# is expected to be the address of
 --   a UTF8-encoded error string
 mkRuntimeErrorId name
- = mkVanillaGlobalWithInfo name runtime_err_ty bottoming_info
+ = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig
                                    `setArityInfo`         1
@@ -756,10 +788,11 @@ mkRuntimeErrorId name
     strict_sig = mkClosedStrictSig [evalDmd] exnRes
               -- exnRes: these throw an exception, not just diverge
 
-    -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
-    --   See Note [Error and friends have an "open-tyvar" forall]
-    runtime_err_ty = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []
-                                   (mkFunTy addrPrimTy openAlphaTy)
+runtimeErrorTy :: Type
+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
+--   See Note [Error and friends have an "open-tyvar" forall]
+runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
+                                 (mkFunTy addrPrimTy openAlphaTy)
 
 {- Note [Error and friends have an "open-tyvar" forall]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -769,4 +802,98 @@ mkRuntimeErrorId name
 Notice the runtime-representation polymorphism. This ensures that
 "error" can be instantiated at unboxed as well as boxed types.
 This is OK because it never returns, so the return type is irrelevant.
+
+
+************************************************************************
+*                                                                      *
+                     aBSENT_ERROR_ID
+*                                                                      *
+************************************************************************
+
+Note [aBSENT_ERROR_ID]
+~~~~~~~~~~~~~~~~~~~~~~
+We use aBSENT_ERROR_ID to build dummy values in workers.  E.g.
+
+   f x = (case x of (a,b) -> b) + 1::Int
+
+The demand analyser figures ot that only the second component of x is
+used, and does a w/w split thus
+
+   f x = case x of (a,b) -> $wf b
+
+   $wf b = let a = absentError "blah"
+               x = (a,b)
+           in <the original RHS of f>
+
+After some simplification, the (absentError "blah") thunk goes away.
+
+------ Tricky wrinkle -------
+Trac #14285 had, roughly
+
+   data T a = MkT a !a
+   {-# INLINABLE f #-}
+   f x = case x of MkT a b -> g (MkT b a)
+
+It turned out that g didn't use the second component, and hence f doesn't use
+the first.  But the stable-unfolding for f looks like
+   \x. case x of MkT a b -> g ($WMkT b a)
+where $WMkT is the wrapper for MkT that evaluates its arguments.  We
+apply the same w/w split to this unfolding (see Note [Worker-wrapper
+for INLINEABLE functions] in WorkWrap) so the template ends up like
+   \b. let a = absentError "blah"
+           x = MkT a b
+        in case x of MkT a b -> g ($WMkT b a)
+
+After doing case-of-known-constructor, and expanding $WMkT we get
+   \b -> g (case absentError "blah" of a -> MkT b a)
+
+Yikes!  That bogusly appears to evaluate the absentError!
+
+This is extremely tiresome.  Another way to think of this is that, in
+Core, it is an invariant that a strict data contructor, like MkT, must
+be applied only to an argument in HNF. So (absentError "blah") had
+better be non-bottom.
+
+So the "solution" is to add a special case for absentError to exprIsHNFlike.
+This allows Simplify.rebuildCase, in the Note [Case to let transformation]
+branch, to convert the case on absentError into a let. We also make
+absentError *not* be diverging, unlike the other error-ids, so that we
+can be sure not to remove the case branches before converting the case to
+a let.
+
+If, by some bug or bizarre happenstance, we ever call absentError, we should
+throw an exception.  This should never happen, of course, but we definitely
+can't return anything.  e.g. if somehow we had
+    case absentError "foo" of
+       Nothing -> ...
+       Just x  -> ...
+then if we return, the case expression will select a field and continue.
+Seg fault city. Better to throw an exception. (Even though we've said
+it is in HNF :-)
+
+It might seem a bit surprising that seq on absentError is simply erased
+
+    absentError "foo" `seq` x ==> x
+
+but that should be okay; since there's no pattern match we can't really
+be relying on anything from it.
 -}
+
+aBSENT_ERROR_ID
+ = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
+ where
+   absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy)
+   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
+   -- lifted-type things; see Note [Absent errors] in WwLib
+   arity_info = vanillaIdInfo `setArityInfo` 1
+   -- NB: no bottoming strictness info, unlike other error-ids.
+   -- See Note [aBSENT_ERROR_ID]
+
+mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
+                 -> String       -- The string to print
+                 -> CoreExpr
+
+mkAbsentErrorApp res_ty err_msg
+  = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ]
+  where
+    err_string = Lit (mkMachString err_msg)
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 28d35528fe..f22d803cb1 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -15,6 +15,8 @@ module PprCore (
         pprRules, pprOptCo
     ) where
 
+import GhcPrelude
+
 import CoreSyn
 import CoreStats (exprStats)
 import Literal( pprLiteral )
@@ -126,10 +128,18 @@ ppr_binding ann (val_bdr, expr)
       -- lambda (the first rendering looks like a nullary join point returning
       -- an n-argument function).
     pp_join_bind join_arity
+      | bndrs `lengthAtLeast` join_arity
       = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
            2 (equals <+> pprCoreExpr rhs)
+      | otherwise -- Yikes!  A join-binding with too few lambda
+                  -- Lint will complain, but we don't want to crash
+                  -- the pretty-printer else we can't see what's wrong
+                  -- So refer to printing  j = e
+      = pp_normal_bind
       where
-        (lhs_bndrs, rhs) = collectNBinders join_arity expr
+        (bndrs, body) = collectBinders expr
+        lhs_bndrs = take join_arity bndrs
+        rhs       = mkLams (drop join_arity bndrs) body
 
 pprParendExpr expr = ppr_expr parens expr
 pprCoreExpr   expr = ppr_expr noParens expr
@@ -213,7 +223,7 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
              ]
     else add_par $
          sep [sep [sep [ text "case" <+> pprCoreExpr expr
-                       , ifPprDebug (text "return" <+> ppr ty)
+                       , whenPprDebug (text "return" <+> ppr ty)
                        , text "of" <+> ppr_bndr var
                        ]
                   , char '{' <+> ppr_case_pat con args <+> arrow
@@ -228,7 +238,7 @@ ppr_expr add_par (Case expr var ty alts)
   = add_par $
     sep [sep [text "case"
                 <+> pprCoreExpr expr
-                <+> ifPprDebug (text "return" <+> ppr ty),
+                <+> whenPprDebug (text "return" <+> ppr ty),
               text "of" <+> ppr_bndr var <+> char '{'],
          nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
          char '}'
@@ -374,7 +384,7 @@ pprTypedLamBinder bind_site debug_on var
   = sdocWithDynFlags $ \dflags ->
     case () of
     _
-      | not debug_on            -- Show case-bound wild bilders only if debug is on
+      | not debug_on            -- Show case-bound wild binders only if debug is on
       , CaseBind <- bind_site
       , isDeadBinder var        -> empty
 
@@ -602,21 +612,3 @@ instance Outputable id => Outputable (Tickish id) where
   ppr (SourceNote span _) =
       hcat [ text "src<", pprUserRealSpan True span, char '>']
 
-{-
------------------------------------------------------
---      Vectorisation declarations
------------------------------------------------------
--}
-
-instance Outputable CoreVect where
-  ppr (Vect     var e)               = hang (text "VECTORISE" <+> ppr var <+> char '=')
-                                         4 (pprCoreExpr e)
-  ppr (NoVect   var)                 = text "NOVECTORISE" <+> ppr var
-  ppr (VectType False var Nothing)   = text "VECTORISE type" <+> ppr var
-  ppr (VectType True  var Nothing)   = text "VECTORISE SCALAR type" <+> ppr var
-  ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+>
-                                       ppr tc
-  ppr (VectType True var (Just tc))  = text "VECTORISE SCALAR type" <+> ppr var <+>
-                                       char '=' <+> ppr tc
-  ppr (VectClass tc)                 = text "VECTORISE class" <+> ppr tc
-  ppr (VectInst var)                 = text "VECTORISE SCALAR instance" <+> ppr var
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index cb9837ed0c..24ce3a9ebb 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -9,17 +9,21 @@ Pattern Matching Coverage Checking.
 
 module Check (
         -- Checking and printing
-        checkSingle, checkMatches, isAnyPmCheckEnabled,
+        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
 
         -- See Note [Type and Term Equality Propagation]
-        genCaseTmCs1, genCaseTmCs2
+        genCaseTmCs1, genCaseTmCs2,
+
+        -- Pattern-match-specific type operations
+        pmIsClosedType, pmTopNormaliseType_maybe
     ) where
 
 #include "HsVersions.h"
 
-import TmOracle
+import GhcPrelude
 
-import BasicTypes
+import TmOracle
+import Unify( tcMatchTy )
 import DynFlags
 import HsSyn
 import TcHsSyn
@@ -27,6 +31,7 @@ import Id
 import ConLike
 import Name
 import FamInstEnv
+import TysPrim (tYPETyCon)
 import TysWiredIn
 import TyCon
 import SrcLoc
@@ -34,24 +39,29 @@ import Util
 import Outputable
 import FastString
 import DataCon
+import PatSyn
 import HscTypes (CompleteMatch(..))
 
 import DsMonad
 import TcSimplify    (tcCheckSatisfiability)
-import TcType        (toTcType, isStringTy, isIntTy, isWordTy)
+import TcType        (isStringTy)
 import Bag
 import ErrUtils
 import Var           (EvVar)
+import TyCoRep
 import Type
 import UniqSupply
-import DsGRHSs       (isTrueLHsExpr)
+import DsUtils       (isTrueLHsExpr)
+import Maybes        (expectJust)
+import qualified GHC.LanguageExtensions as LangExt
 
 import Data.List     (find)
-import Data.Maybe    (isJust, fromMaybe)
-import Control.Monad (forM, when, forM_)
+import Data.Maybe    (catMaybes, isJust, fromMaybe)
+import Control.Monad (forM, when, forM_, zipWithM)
 import Coercion
 import TcEvidence
 import IOEnv
+import qualified Data.Semigroup as Semi
 
 import ListT (ListT(..), fold, select)
 
@@ -93,22 +103,27 @@ liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
 -- Pick the first match complete covered match or otherwise the "best" match.
 -- The best match is the one with the least uncovered clauses, ties broken
 -- by the number of inaccessible clauses followed by number of redundant
--- clauses
+-- clauses.
+--
+-- This is specified in the
+-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the
+-- users' guide. If you update the implementation of this function, make sure
+-- to update that section of the users' guide as well.
 getResult :: PmM PmResult -> DsM PmResult
-getResult ls = do
-  res <- fold ls goM (pure Nothing)
-  case res of
-    Nothing -> panic "getResult is empty"
-    Just a -> return a
+getResult ls
+  = do { res <- fold ls goM (pure Nothing)
+       ; case res of
+            Nothing -> panic "getResult is empty"
+            Just a  -> return a }
   where
     goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
-    goM mpm dpm = do
-      pmr <- dpm
-      return $ go pmr mpm
+    goM mpm dpm = do { pmr <- dpm
+                     ; return $ Just $ go pmr mpm }
+
     -- Careful not to force unecessary results
-    go :: Maybe PmResult -> PmResult -> Maybe PmResult
-    go Nothing rs = Just rs
-    go old@(Just (PmResult prov rs (UncoveredPatterns us) is)) new
+    go :: Maybe PmResult -> PmResult -> PmResult
+    go Nothing rs = rs
+    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new
       | null us && null rs && null is = old
       | otherwise =
         let PmResult prov' rs' (UncoveredPatterns us') is' = new
@@ -116,8 +131,8 @@ getResult ls = do
                 `mappend` (compareLength is is')
                 `mappend` (compareLength rs rs')
                 `mappend` (compare prov prov') of
-              GT  -> Just new
-              EQ  -> Just new
+              GT  -> new
+              EQ  -> new
               LT  -> old
     go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new
       = panic "getResult: No inhabitation candidates"
@@ -141,6 +156,9 @@ data PmPat :: PatTy -> * where
   PmGrd  :: { pm_grd_pv   :: PatVec
             , pm_grd_expr :: PmExpr  } -> PmPat 'PAT
 
+instance Outputable (PmPat a) where
+  ppr = pprPmPatDebug
+
 -- data T a where
 --     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]
 -- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r
@@ -180,11 +198,14 @@ instance Outputable Covered where
 
 -- Like the or monoid for booleans
 -- Covered = True, Uncovered = False
+instance Semi.Semigroup Covered where
+  Covered <> _ = Covered
+  _ <> Covered = Covered
+  NotCovered <> NotCovered = NotCovered
+
 instance Monoid Covered where
   mempty = NotCovered
-  Covered `mappend` _ = Covered
-  _ `mappend` Covered = Covered
-  NotCovered `mappend` NotCovered = NotCovered
+  mappend = (Semi.<>)
 
 data Diverged = Diverged | NotDiverged
   deriving Show
@@ -193,11 +214,14 @@ instance Outputable Diverged where
   ppr Diverged = text "Diverged"
   ppr NotDiverged = text "NotDiverged"
 
+instance Semi.Semigroup Diverged where
+  Diverged <> _ = Diverged
+  _ <> Diverged = Diverged
+  NotDiverged <> NotDiverged = NotDiverged
+
 instance Monoid Diverged where
   mempty = NotDiverged
-  Diverged `mappend` _ = Diverged
-  _ `mappend` Diverged = Diverged
-  NotDiverged `mappend` NotDiverged = NotDiverged
+  mappend = (Semi.<>)
 
 -- | When we learned that a given match group is complete
 data Provenance =
@@ -209,17 +233,20 @@ data Provenance =
 instance Outputable Provenance where
   ppr  = text . show
 
+instance Semi.Semigroup Provenance where
+  FromComplete <> _ = FromComplete
+  _ <> FromComplete = FromComplete
+  _ <> _ = FromBuiltin
+
 instance Monoid Provenance where
   mempty = FromBuiltin
-  FromComplete `mappend` _ = FromComplete
-  _ `mappend` FromComplete = FromComplete
-  _ `mappend` _ = FromBuiltin
+  mappend = (Semi.<>)
 
 data PartialResult = PartialResult {
-                        presultProvenence :: Provenance
+                        presultProvenance :: Provenance
                          -- keep track of provenance because we don't want
                          -- to warn about redundant matches if the result
-                         -- is contaiminated with a COMPLETE pragma
+                         -- is contaminated with a COMPLETE pragma
                       , presultCovered :: Covered
                       , presultUncovered :: Uncovered
                       , presultDivergent :: Diverged }
@@ -229,14 +256,19 @@ instance Outputable PartialResult where
            = text "PartialResult" <+> ppr prov <+> ppr c
                                   <+> ppr d <+> ppr vsa
 
+
+instance Semi.Semigroup PartialResult where
+  (PartialResult prov1 cs1 vsa1 ds1)
+    <> (PartialResult prov2 cs2 vsa2 ds2)
+      = PartialResult (prov1 Semi.<> prov2)
+                      (cs1 Semi.<> cs2)
+                      (vsa1 Semi.<> vsa2)
+                      (ds1 Semi.<> ds2)
+
+
 instance Monoid PartialResult where
   mempty = PartialResult mempty mempty [] mempty
-  (PartialResult prov1 cs1 vsa1 ds1)
-    `mappend` (PartialResult prov2 cs2 vsa2 ds2)
-      = PartialResult (prov1 `mappend` prov2)
-                      (cs1 `mappend` cs2)
-                      (vsa1 `mappend` vsa2)
-                      (ds1 `mappend` ds2)
+  mappend = (Semi.<>)
 
 -- newtype ChoiceOf a = ChoiceOf [a]
 
@@ -253,9 +285,9 @@ instance Monoid PartialResult where
 --
 data PmResult =
   PmResult {
-      pmresultProvenance :: Provenance
-    , pmresultRedundant :: [Located [LPat GhcTc]]
-    , pmresultUncovered :: UncoveredCandidates
+      pmresultProvenance   :: Provenance
+    , pmresultRedundant    :: [Located [LPat GhcTc]]
+    , pmresultUncovered    :: UncoveredCandidates
     , pmresultInaccessible :: [Located [LPat GhcTc]] }
 
 -- | Either a list of patterns that are not covered, or their type, in case we
@@ -314,6 +346,23 @@ checkSingle' locn var p = do
     (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs
   where m = [L locn [L locn p]]
 
+-- | Exhaustive for guard matches, is used for guards in pattern bindings and
+-- in @MultiIf@ expressions.
+checkGuardMatches :: HsMatchContext Name          -- Match context
+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs
+                  -> DsM ()
+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
+    dflags <- getDynFlags
+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
+        dsMatchContext = DsMatchContext hs_ctx combinedLoc
+        match = L combinedLoc $
+                  Match { m_ext = noExt
+                        , m_ctxt = hs_ctx
+                        , m_pats = []
+                        , m_grhss = guards }
+    checkMatches dflags dsMatchContext [] [match]
+checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"
+
 -- | Check a matchgroup (case, functions, etc.)
 checkMatches :: DynFlags -> DsMatchContext
              -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
@@ -340,7 +389,7 @@ checkMatches' vars matches
   | otherwise = do
       liftD resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
-      tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
+      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))
       (prov, rs,us,ds) <- go matches missing
       return $ PmResult {
                    pmresultProvenance   = prov
@@ -372,48 +421,363 @@ checkMatches' vars matches
         (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)
 
     hsLMatchToLPats :: LMatch id body -> Located [LPat id]
-    hsLMatchToLPats (L l (Match _ pats _ _)) = L l pats
+    hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
+    hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'"
 
 -- | Check an empty case expression. Since there are no clauses to process, we
 --   only compute the uncovered set. See Note [Checking EmptyCase Expressions]
 --   for details.
 checkEmptyCase' :: Id -> PmM PmResult
 checkEmptyCase' var = do
-  tm_css <- map toComplex . bagToList <$> liftD getTmCsDs
-  case tmOracle initialTmState tm_css of
-    Just tm_state -> do
-      ty_css        <- liftD getDictsDs
-      fam_insts     <- liftD dsGetFamInstEnvs
-      mb_candidates <- inhabitationCandidates fam_insts (idType var)
-      case mb_candidates of
-        -- Inhabitation checking failed / the type is trivially inhabited
-        Left ty -> return (uncoveredWithTy ty)
-
-        -- A list of inhabitant candidates is available: Check for each
-        -- one for the satisfiability of the constraints it gives rise to.
-        Right candidates -> do
-          missing_m <- flip concatMapM candidates $ \(va,tm_ct,ty_cs) -> do
-            let all_ty_cs = unionBags ty_cs ty_css
-            sat_ty <- tyOracle all_ty_cs
-            return $ case (sat_ty, tmOracle tm_state (tm_ct:tm_css)) of
-              (True, Just tm_state') -> [(va, all_ty_cs, tm_state')]
-              _non_sat               -> []
-          let mkValVec (va,all_ty_cs,tm_state')
-                = ValVec [va] (MkDelta all_ty_cs tm_state')
-              uncovered = UncoveredPatterns (map mkValVec missing_m)
-          return $ if null missing_m
-            then emptyPmResult
-            else PmResult FromBuiltin [] uncovered []
-    Nothing -> return emptyPmResult
-
--- | Generate all inhabitation candidates for a given type. The result is
--- either (Left ty), if the type cannot be reduced to a closed algebraic type
--- (or if it's one trivially inhabited, like Int), or (Right candidates), if it
--- can. In this case, the candidates are the singnature of the tycon, each one
--- accompanied by the term- and type- constraints it gives rise to.
+  tm_ty_css     <- pmInitialTmTyCs
+  fam_insts     <- liftD dsGetFamInstEnvs
+  mb_candidates <- inhabitationCandidates fam_insts (idType var)
+  case mb_candidates of
+    -- Inhabitation checking failed / the type is trivially inhabited
+    Left ty -> return (uncoveredWithTy ty)
+
+    -- A list of inhabitant candidates is available: Check for each
+    -- one for the satisfiability of the constraints it gives rise to.
+    Right (_, candidates) -> do
+      missing_m <- flip mapMaybeM candidates $
+          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                                , ic_ty_cs = ty_cs
+                                , ic_strict_arg_tys = strict_arg_tys } -> do
+        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys
+        pure $ fmap (ValVec [va]) mb_sat
+      return $ if null missing_m
+        then emptyPmResult
+        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []
+
+-- | Returns 'True' if the argument 'Type' is a fully saturated application of
+-- a closed type constructor.
+--
+-- Closed type constructors are those with a fixed right hand side, as
+-- opposed to e.g. associated types. These are of particular interest for
+-- pattern-match coverage checking, because GHC can exhaustively consider all
+-- possible forms that values of a closed type can take on.
+--
+-- Note that this function is intended to be used to check types of value-level
+-- patterns, so as a consequence, the 'Type' supplied as an argument to this
+-- function should be of kind @Type@.
+pmIsClosedType :: Type -> Bool
+pmIsClosedType ty
+  = case splitTyConApp_maybe ty of
+      Just (tc, ty_args)
+             | is_algebraic_like tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
+  where
+    -- This returns True for TyCons which /act like/ algebraic types.
+    -- (See "Type#type_classification" for what an algebraic type is.)
+    --
+    -- This is qualified with \"like\" because of a particular special
+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE
+    -- is conceptually a datatype (and thus algebraic), but in practice it is
+    -- a primitive builtin type, so we must check for it specially.
+    --
+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,
+    -- pattern-matching context. However, at the kind level, TYPE is certainly
+    -- not closed! Since this function is specifically tailored towards pattern
+    -- matching, however, it's OK to label TYPE as closed.
+    is_algebraic_like :: TyCon -> Bool
+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon
+
+pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type)
+-- ^ Get rid of *outermost* (or toplevel)
+--      * type function redex
+--      * data family redex
+--      * newtypes
+--
+-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a
+-- coercion, it returns useful information for issuing pattern matching
+-- warnings. See Note [Type normalisation for EmptyCase] for details.
+pmTopNormaliseType_maybe env typ
+  = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ
+       return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty)
+  where
+    -- Find the first type in the sequence of rewrites that is a data type,
+    -- newtype, or a data family application (not the representation tycon!).
+    -- This is the one that is equal (in source Haskell) to the initial type.
+    -- If none is found in the list, then all of them are type family
+    -- applications, so we simply return the last one, which is the *simplest*.
+    eq_src_ty :: Type -> [Type] -> Type
+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)
+
+    is_closed_or_data_family :: Type -> Bool
+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty
+
+    -- For efficiency, represent both lists as difference lists.
+    -- comb performs the concatenation, for both lists.
+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)
+
+    stepper = newTypeStepper `composeSteppers` tyFamStepper
+
+    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])
+    newTypeStepper rec_nts tc tys
+      | Just (ty', _co) <- instNewTyCon_maybe tc tys
+      = case checkRecTc rec_nts tc of
+          Just rec_nts' -> let tyf = ((TyConApp tc tys):)
+                               tmf = ((tyConSingleDataCon tc):)
+                           in  NS_Step rec_nts' ty' (tyf, tmf)
+          Nothing       -> NS_Abort
+      | otherwise
+      = NS_Done
+
+    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])
+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family
+      = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in
+          -- NB: It's OK to use normaliseTcArgs here instead of
+          -- normalise_tc_args (which takes the LiftingContext described
+          -- in Note [Normalising types]) because the reduceTyFamApp below
+          -- works only at top level. We'll never recur in this function
+          -- after reducing the kind of a bound tyvar.
+
+        case reduceTyFamApp_maybe env Representational tc ntys of
+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)
+          _               -> NS_Done
+
+-- | Determine suitable constraints to use at the beginning of pattern-match
+-- coverage checking by consulting the sets of term and type constraints
+-- currently in scope. If one of these sets of constraints is unsatisfiable,
+-- use an empty set in its place. (See
+-- @Note [Recovering from unsatisfiable pattern-matching constraints]@
+-- for why this is done.)
+pmInitialTmTyCs :: PmM Delta
+pmInitialTmTyCs = do
+  ty_cs  <- liftD getDictsDs
+  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs
+  sat_ty <- tyOracle ty_cs
+  let initTyCs = if sat_ty then ty_cs else emptyBag
+      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)
+  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }
+
+{-
+Note [Recovering from unsatisfiable pattern-matching constraints]
+~~~~~~~~~~~~~~~~
+Consider the following code (see #12957 and #15450):
+
+  f :: Int ~ Bool => ()
+  f = case True of { False -> () }
+
+We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC
+used not to do this; in fact, it would warn that the match was /redundant/!
+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the
+coverage checker deems any matches with unsatifiable constraint sets to be
+unreachable.
+
+We decide to better than this. When beginning coverage checking, we first
+check if the constraints in scope are unsatisfiable, and if so, we start
+afresh with an empty set of constraints. This way, we'll get the warnings
+that we expect.
+-}
+
+-- | Given a conlike's term constraints, type constraints, and strict argument
+-- types, check if they are satisfiable.
+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet
+-- Their Match paper.)
+--
+-- For the purposes of efficiency, this takes as separate arguments the
+-- ambient term and type constraints (which are known beforehand to be
+-- satisfiable), as well as the new term and type constraints (which may not
+-- be satisfiable). This lets us implement two mini-optimizations:
+--
+-- * If there are no new type constraints, then don't bother initializing
+--   the type oracle, since it's redundant to do so.
+-- * Since the new term constraint is a separate argument, we only need to
+--   execute one iteration of the term oracle (instead of traversing the
+--   entire set of term constraints).
+--
+-- Taking strict argument types into account is something which was not
+-- discussed in GADTs Meet Their Match. For an explanation of what role they
+-- serve, see @Note [Extensions to GADTs Meet Their Match]@.
+pmIsSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> [Type]    -- ^ The strict argument types.
+  -> PmM (Maybe Delta)
+               -- ^ @'Just' delta@ if the constraints (@delta@) are
+               -- satisfiable, and each strict argument type is inhabitable.
+               -- 'Nothing' otherwise.
+pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do
+  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs
+  case mb_sat of
+    Nothing -> pure Nothing
+    Just delta -> do
+      -- We know that the term and type constraints are inhabitable, so now
+      -- check if each strict argument type is inhabitable.
+      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys
+      pure $ if all_non_void -- Check if each strict argument type
+                             -- is inhabitable
+                then Just delta
+                else Nothing
+
+-- | Like 'pmIsSatisfiable', but only checks if term and type constraints are
+-- satisfiable, and doesn't bother checking anything related to strict argument
+-- types.
+tmTyCsAreSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> PmM (Maybe Delta)
+       -- ^ @'Just' delta@ if the constraints (@delta@) are
+       -- satisfiable. 'Nothing' otherwise.
+tmTyCsAreSatisfiable
+    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })
+    new_tm_c new_ty_cs = do
+  let ty_cs = new_ty_cs `unionBags` amb_ty_cs
+  sat_ty <- if isEmptyBag new_ty_cs
+               then pure True
+               else tyOracle ty_cs
+  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of
+           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs
+                                                 , delta_tm_cs = term_cs }
+           _unsat               -> Nothing
+
+-- | Implements two performance optimizations, as described in the
+-- \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool
+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do
+  fam_insts <- liftD dsGetFamInstEnvs
+  let tys_to_check = filterOut (definitelyInhabitedType fam_insts)
+                               strict_arg_tys
+      rec_max_bound | tys_to_check `lengthExceeds` 1
+                    = 1
+                    | otherwise
+                    = defaultRecTcMaxBound
+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts
+  allM (nonVoid rec_ts' amb_cs) tys_to_check
+
+-- | Checks if a strict argument type of a conlike is inhabitable by a
+-- terminating value (i.e, an 'InhabitationCandidate').
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+nonVoid
+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.
+  -> Delta        -- ^ The ambient term/type constraints (known to be
+                  --   satisfiable).
+  -> Type         -- ^ The strict argument type.
+  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by
+                  --   a terminating value (i.e., an 'InhabitationCandidate').
+                  --   'False' if it is definitely uninhabitable by anything
+                  --   (except bottom).
+nonVoid rec_ts amb_cs strict_arg_ty = do
+  fam_insts <- liftD dsGetFamInstEnvs
+  mb_cands <- inhabitationCandidates fam_insts strict_arg_ty
+  case mb_cands of
+    Right (tc, cands)
+      |  Just rec_ts' <- checkRecTc rec_ts tc
+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands
+           -- A strict argument type is inhabitable by a terminating value if
+           -- at least one InhabitationCandidate is inhabitable.
+    _ -> pure True
+           -- Either the type is trivially inhabited or we have exceeded the
+           -- recursion depth for some TyCon (so bail out and conservatively
+           -- claim the type is inhabited).
+  where
+    -- Checks if an InhabitationCandidate for a strict argument type:
+    --
+    -- (1) Has satisfiable term and type constraints.
+    -- (2) Has 'nonVoid' strict argument types (we bail out of this
+    --     check if recursion is detected).
+    --
+    -- See Note [Extensions to GADTs Meet Their Match]
+    cand_is_inhabitable :: RecTcChecker -> Delta
+                        -> InhabitationCandidate -> PmM Bool
+    cand_is_inhabitable rec_ts amb_cs
+      (InhabitationCandidate{ ic_tm_ct          = new_term_c
+                            , ic_ty_cs          = new_ty_cs
+                            , ic_strict_arg_tys = new_strict_arg_tys }) = do
+        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs
+        case mb_sat of
+          Nothing -> pure False
+          Just new_delta -> do
+            checkAllNonVoid rec_ts new_delta new_strict_arg_tys
+
+-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one
+-- constructor @C@ such that:
+--
+-- 1. @C@ has no equality constraints.
+-- 2. @C@ has no strict argument types.
+--
+-- See the \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+definitelyInhabitedType :: FamInstEnvs -> Type -> Bool
+definitelyInhabitedType env ty
+  | Just (_, cons, _) <- pmTopNormaliseType_maybe env ty
+  = any meets_criteria cons
+  | otherwise
+  = False
+  where
+    meets_criteria :: DataCon -> Bool
+    meets_criteria con =
+      null (dataConEqSpec con) && -- (1)
+      null (dataConImplBangs con) -- (2)
+
+{- Note [Type normalisation for EmptyCase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+EmptyCase is an exception for pattern matching, since it is strict. This means
+that it boils down to checking whether the type of the scrutinee is inhabited.
+Function pmTopNormaliseType_maybe gets rid of the outermost type function/data
+family redex and newtypes, in search of an algebraic type constructor, which is
+easier to check for inhabitation.
+
+It returns 3 results instead of one, because there are 2 subtle points:
+1. Newtypes are isomorphic to the underlying type in core but not in the source
+   language,
+2. The representational data family tycon is used internally but should not be
+   shown to the user
+
+Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then
+  (a) src_ty is the rewritten type which we can show to the user. That is, the
+      type we get if we rewrite type families but not data families or
+      newtypes.
+  (b) dcs is the list of data constructors "skipped", every time we normalise a
+      newtype to it's core representation, we keep track of the source data
+      constructor.
+  (c) core_ty is the rewritten type. That is,
+        pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty)
+      implies
+        topNormaliseType_maybe env ty = Just (co, core_ty)
+      for some coercion co.
+
+To see how all cases come into play, consider the following example:
+
+  data family T a :: *
+  data instance T Int = T1 | T2 Bool
+  -- Which gives rise to FC:
+  --   data T a
+  --   data R:TInt = T1 | T2 Bool
+  --   axiom ax_ti : T Int ~R R:TInt
+
+  newtype G1 = MkG1 (T Int)
+  newtype G2 = MkG2 G1
+
+  type instance F Int  = F Char
+  type instance F Char = G2
+
+In this case pmTopNormaliseType_maybe env (F Int) results in
+
+  Just (G2, [MkG2,MkG1], R:TInt)
+
+Which means that in source Haskell:
+  - G2 is equivalent to F Int (in contrast, G1 isn't).
+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).
+-}
+
+-- | Generate all 'InhabitationCandidate's for a given type. The result is
+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type
+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,
+-- if it can. In this case, the candidates are the signature of the tycon, each
+-- one accompanied by the term- and type- constraints it gives rise to.
 -- See also Note [Checking EmptyCase Expressions]
 inhabitationCandidates :: FamInstEnvs -> Type
-                       -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])
+                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))
 inhabitationCandidates fam_insts ty
   = case pmTopNormaliseType_maybe fam_insts ty of
       Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs
@@ -431,18 +795,28 @@ inhabitationCandidates fam_insts ty
 
     -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe
     alts_to_check :: Type -> Type -> [DataCon]
-                  -> PmM (Either Type [(ValAbs, ComplexEq, Bag EvVar)])
+                  -> PmM (Either Type (TyCon, [InhabitationCandidate]))
     alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of
       Just (tc, _)
-        | tc `elem` trivially_inhabited -> case dcs of
-            []    -> return (Left src_ty)
-            (_:_) -> do var <- liftD $ mkPmId (toTcType core_ty)
-                        let va = build_tm (PmVar var) dcs
-                        return $ Right [(va, mkIdEq var, emptyBag)]
-        | isClosedAlgType core_ty -> liftD $ do
-            var  <- mkPmId (toTcType core_ty) -- it would be wrong to unify x
-            alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
-            return $ Right [(build_tm va dcs, eq, cs) | (va, eq, cs) <- alts]
+        |  tc `elem` trivially_inhabited
+        -> case dcs of
+             []    -> return (Left src_ty)
+             (_:_) -> do var <- liftD $ mkPmId core_ty
+                         let va = build_tm (PmVar var) dcs
+                         return $ Right (tc, [InhabitationCandidate
+                           { ic_val_abs = va, ic_tm_ct = mkIdEq var
+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])
+
+        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)
+           -- Don't consider abstract tycons since we don't know what their
+           -- constructors are, which makes the results of coverage checking
+           -- them extremely misleading.
+        -> liftD $ do
+             var  <- mkPmId core_ty -- it would be wrong to unify x
+             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
+             return $ Right
+               (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}
+                    | alt <- alts ])
       -- For other types conservatively assume that they are inhabited.
       _other -> return (Left src_ty)
 
@@ -505,12 +879,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
 -- | A fake guard pattern (True <- _) used to represent cases we cannot handle
 fake_pat :: Pattern
 fake_pat = PmGrd { pm_grd_pv   = [truePattern]
-                 , pm_grd_expr = PmExprOther EWildPat }
+                 , pm_grd_expr = PmExprOther (EWildPat noExt) }
 {-# INLINE fake_pat #-}
 
 -- | Check whether a guard pattern is generated by the checker (unhandled)
 isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
   | c == trueDataCon = True
   | otherwise        = False
 isFakeGuard _pats _e = False
@@ -553,25 +927,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
 
 translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
 translatePat fam_insts pat = case pat of
-  WildPat ty  -> mkPmVars [ty]
-  VarPat  id  -> return [PmVar (unLoc id)]
-  ParPat p    -> translatePat fam_insts (unLoc p)
-  LazyPat _   -> mkPmVars [hsPatType pat] -- like a variable
+  WildPat  ty  -> mkPmVars [ty]
+  VarPat _ id  -> return [PmVar (unLoc id)]
+  ParPat _ p   -> translatePat fam_insts (unLoc p)
+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable
 
   -- ignore strictness annotations for now
-  BangPat p   -> translatePat fam_insts (unLoc p)
+  BangPat _ p  -> translatePat fam_insts (unLoc p)
 
-  AsPat lid p -> do
+  AsPat _ lid p -> do
      -- Note [Translating As Patterns]
     ps <- translatePat fam_insts (unLoc p)
     let [e] = map vaToPmExpr (coercePatVec ps)
         g   = PmGrd [PmVar (unLoc lid)] e
     return (ps ++ [g])
 
-  SigPatOut p _ty -> translatePat fam_insts (unLoc p)
+  SigPat _ty p -> translatePat fam_insts (unLoc p)
 
   -- See Note [Translate CoPats]
-  CoPat wrapper p ty
+  CoPat _ wrapper p ty
     | isIdHsWrapper wrapper                   -> translatePat fam_insts p
     | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p
     | otherwise -> do
@@ -581,37 +955,50 @@ translatePat fam_insts pat = case pat of
         return [xp,g]
 
   -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
-  NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
+  NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
 
   -- (fun -> pat)   ===>   x (pat <- fun x)
-  ViewPat lexpr lpat arg_ty -> do
+  ViewPat arg_ty lexpr lpat -> do
     ps <- translatePat fam_insts (unLoc lpat)
     -- See Note [Guards and Approximation]
     case all cantFailPattern ps of
       True  -> do
         (xp,xe) <- mkPmId2Forms arg_ty
-        let g = mkGuard ps (HsApp lexpr xe)
+        let g = mkGuard ps (HsApp noExt lexpr xe)
         return [xp,g]
       False -> mkCanFailPmPat arg_ty
 
   -- list
-  ListPat ps ty Nothing -> do
+  ListPat (ListPatTc ty Nothing) ps -> do
     foldr (mkListPatVec ty) [nilPattern ty]
       <$> translatePatVec fam_insts (map unLoc ps)
 
   -- overloaded list
-  ListPat lpats elem_ty (Just (pat_ty, _to_list))
-    | Just e_ty <- splitListTyConApp_maybe pat_ty
-    , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
-         -- elem_ty is frequently something like
-         -- `Item [Int]`, but we prefer `Int`
-    , norm_elem_ty `eqType` e_ty ->
-        -- We have to ensure that the element types are exactly the same.
-        -- Otherwise, one may give an instance IsList [Int] (more specific than
-        -- the default IsList [a]) with a different implementation for `toList'
-        translatePat fam_insts (ListPat lpats e_ty Nothing)
-      -- See Note [Guards and Approximation]
-    | otherwise -> mkCanFailPmPat pat_ty
+  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do
+    dflags <- getDynFlags
+    if xopt LangExt.RebindableSyntax dflags
+       then mkCanFailPmPat pat_ty
+       else case splitListTyConApp_maybe pat_ty of
+              Just e_ty -> translatePat fam_insts
+                                        (ListPat (ListPatTc e_ty Nothing) lpats)
+              Nothing   -> mkCanFailPmPat pat_ty
+    -- (a) In the presence of RebindableSyntax, we don't know anything about
+    --     `toList`, we should treat `ListPat` as any other view pattern.
+    --
+    -- (b) In the absence of RebindableSyntax,
+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern
+    --       as ordinary list pattern. Although we can give an instance
+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in
+    --       practice, we almost never do that. We assume the `_to_list` is
+    --       the `toList` from `instance IsList [a]`.
+    --
+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.
+    --
+    -- See Trac #14547, especially comment#9 and comment#10.
+    --
+    -- Here we construct CanFailPmPat directly, rather can construct a view
+    -- pattern and do further translation as an optimization, for the reason,
+    -- see Note [Guards and Approximation].
 
   ConPatOut { pat_con     = L _ con
             , pat_arg_tys = arg_tys
@@ -629,26 +1016,29 @@ translatePat fam_insts pat = case pat of
                       , pm_con_dicts   = dicts
                       , pm_con_args    = args }]
 
-  NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  NPat _ (L _ olit) mb_neg _
+    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
+    , isStringTy ty ->
+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
+    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]
 
-  LitPat lit
-      -- If it is a string then convert it to a list of characters
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  LitPat _ lit
     | HsString src s <- lit ->
         foldr (mkListPatVec charTy) [nilPattern charTy] <$>
-          translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
     | otherwise -> return [mkLitPattern lit]
 
-  PArrPat ps ty -> do
-    tidy_ps <- translatePatVec fam_insts (map unLoc ps)
-    let fake_con = RealDataCon (parrFakeCon (length ps))
-    return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
-
-  TuplePat ps boxity tys -> do
+  TuplePat tys ps boxity -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
     return [vanillaConPattern tuple_con tys (concat tidy_ps)]
 
-  SumPat p alt arity ty -> do
+  SumPat ty p alt arity -> do
     tidy_p <- translatePat fam_insts (unLoc p)
     let sum_con = RealDataCon (sumDataCon alt arity)
     return [vanillaConPattern sum_con ty tidy_p]
@@ -657,31 +1047,92 @@ translatePat fam_insts pat = case pat of
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
   SplicePat {} -> panic "Check.translatePat: SplicePat"
-  SigPatIn  {} -> panic "Check.translatePat: SigPatIn"
-
--- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
-translateNPat :: FamInstEnvs
-              -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
-              -> DsM PatVec
-translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
-  | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
-  = translatePat fam_insts (LitPat (HsString src s))
-  | not type_change, isIntTy    ty, HsIntegral i <- val
-  = translatePat fam_insts
-                 (LitPat $ case mb_neg of
-                             Nothing -> HsInt def i
-                             Just _  -> HsInt def (negateIntegralLit i))
-  | not type_change, isWordTy   ty, HsIntegral i <- val
-  = translatePat fam_insts
-                 (LitPat $ case mb_neg of
-                             Nothing -> HsWordPrim (il_text i) (il_value i)
-                             Just _  -> let ni = negateIntegralLit i in
-                                        HsWordPrim (il_text ni) (il_value ni))
-  where
-    type_change = not (outer_ty `eqType` ty)
-
-translateNPat _ ol mb_neg _
-  = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
+  XPat      {} -> panic "Check.translatePat: XPat"
+
+{- Note [Translate Overloaded Literal for Exhaustiveness Checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The translation of @NPat@ in exhaustiveness checker is a bit different
+from translation in pattern matcher.
+
+  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we
+    translate integral literals to HsIntPrim or HsWordPrim and translate
+    overloaded strings to HsString.
+
+  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use
+    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,
+    however we generate `PmOLit` for HsOverLit, rather than refine
+    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do
+    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness
+    checker will fail to match the literals patterns correctly. See
+    Trac #14546.
+
+  In Note [Undecidable Equality for Overloaded Literals], we say: "treat
+  overloaded literals that look different as different", but previously we
+  didn't do such things.
+
+  Now, we translate the literal value to match and the literal patterns
+  consistently:
+
+  * For integral literals, we parse both the integral literal value and
+    the patterns as OverLit HsIntegral. For example:
+
+      case 0::Int of
+          0 -> putStrLn "A"
+          1 -> putStrLn "B"
+          _ -> putStrLn "C"
+
+    When checking the exhaustiveness of pattern matching, we translate the 0
+    in value position as PmOLit, but translate the 0 and 1 in pattern position
+    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the
+    equality and report warning of "Pattern match is redundant" on pattern 0,
+    as reported in Trac #14546. In this patch we remove the specialization of
+    OverLit patterns, and keep the overloaded number literal in pattern as it
+    is to maintain the consistency. We know nothing about the `fromInteger`
+    method (see Note [Undecidable Equality for Overloaded Literals]). Now we
+    can capture the exhaustiveness of pattern 0 and the redundancy of pattern
+    1 and _.
+
+  * For string literals, we parse the string literals as HsString. When
+    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.
+    For example:
+
+      case "foo" of
+          "foo" -> putStrLn "A"
+          "bar" -> putStrLn "B"
+          "baz" -> putStrLn "C"
+
+    Previously, the overloaded string values are translated to PmOLit and the
+    non-overloaded string values are translated to PmSLit. However the string
+    patterns, both overloaded and non-overloaded, are translated to list of
+    characters. The inconsistency leads to wrong warnings about redundant and
+    non-exhaustive pattern matching warnings, as reported in Trac #14546.
+
+    In order to catch the redundant pattern in following case:
+
+      case "foo" of
+          ('f':_) -> putStrLn "A"
+          "bar" -> putStrLn "B"
+
+    in this patch, we translate non-overloaded string literals, both in value
+    position and pattern position, as list of characters. For overloaded string
+    literals, we only translate it to list of characters only when it's type
+    is stringTy, since we know nothing about the toString methods. But we know
+    that if two overloaded strings are syntax equal, then they are equal. Then
+    if it's type is not stringTy, we just translate it to PmOLit. We can still
+    capture the exhaustiveness of pattern "foo" and the redundancy of pattern
+    "bar" and "baz" in the following code:
+
+      {-# LANGUAGE OverloadedStrings #-}
+      main = do
+        case "foo" of
+            "foo" -> putStrLn "A"
+            "bar" -> putStrLn "B"
+            "baz" -> putStrLn "C"
+
+  We must ensure that doing the same translation to literal values and patterns
+  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to
+  Trac #14546.
+-}
 
 -- | Translate a list of patterns (Note: each pattern is translated
 -- to a pattern vector but we do not concatenate the results).
@@ -747,16 +1198,18 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
 -- Translate a single match
 translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
                -> DsM (PatVec,[PatVec])
-translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
+translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
   pats'   <- concat <$> translatePatVec fam_insts pats
   guards' <- mapM (translateGuards fam_insts) guards
   return (pats', guards')
   where
     extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
-    extractGuards (L _ (GRHS gs _)) = map unLoc gs
+    extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
+    extractGuards (L _ (XGRHS _)) = panic "translateMatch"
 
     pats   = map unLoc lpats
     guards = map extractGuards (grhssGRHSs grhss)
+translateMatch _ (L _ (XMatch _)) = panic "translateMatch"
 
 -- -----------------------------------------------------------------------
 -- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
@@ -804,14 +1257,15 @@ cantFailPattern _ = False
 -- | Translate a guard statement to Pattern
 translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
 translateGuard fam_insts guard = case guard of
-  BodyStmt   e _ _ _ -> translateBoolGuard e
-  LetStmt      binds -> translateLet (unLoc binds)
-  BindStmt p e _ _ _ -> translateBind fam_insts p e
+  BodyStmt _   e _ _ -> translateBoolGuard e
+  LetStmt  _   binds -> translateLet (unLoc binds)
+  BindStmt _ p e _ _ -> translateBind fam_insts p e
   LastStmt        {} -> panic "translateGuard LastStmt"
   ParStmt         {} -> panic "translateGuard ParStmt"
   TransStmt       {} -> panic "translateGuard TransStmt"
   RecStmt         {} -> panic "translateGuard RecStmt"
   ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
+  XStmtLR         {} -> panic "translateGuard RecStmt"
 
 -- | Translate let-bindings
 translateLet :: HsLocalBinds GhcTc -> DsM PatVec
@@ -881,7 +1335,7 @@ An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
 problem is exactly like above, as its solution. For future reference, the code
 below is the *right thing to do*:
 
-   ListPat lpats elem_ty (Just (pat_ty, to_list))
+   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
      otherwise -> do
        (xp, xe) <- mkPmId2Forms pat_ty
        ps       <- translatePatVec (map unLoc lpats)
@@ -894,7 +1348,7 @@ below is the *right thing to do*:
 The case with literals is a bit different. a literal @l@ should be translated
 to @x (True <- x == from l)@. Since we want to have better warnings for
 overloaded literals as it is a very common feature, we treat them differently.
-They are mainly covered in Note [Undecidable Equality on Overloaded Literals]
+They are mainly covered in Note [Undecidable Equality for Overloaded Literals]
 in PmExpr.
 
 4. N+K Patterns & Pattern Synonyms
@@ -952,9 +1406,168 @@ pmPatType (PmGrd  { pm_grd_pv  = pv })
   = ASSERT(patVecArity pv == 1) (pmPatType p)
   where Just p = find ((==1) . patternArity) pv
 
--- | Generate a value abstraction for a given constructor (generate
+-- | Information about a conlike that is relevant to coverage checking.
+-- It is called an \"inhabitation candidate\" since it is a value which may
+-- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')
+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict
+-- argument types ('ic_strict_arg_tys') are inhabitable.
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+data InhabitationCandidate =
+  InhabitationCandidate
+  { ic_val_abs        :: ValAbs
+  , ic_tm_ct          :: ComplexEq
+  , ic_ty_cs          :: Bag EvVar
+  , ic_strict_arg_tys :: [Type]
+  }
+
+{-
+Note [Extensions to GADTs Meet Their Match]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GADTs Meet Their Match paper presents the formalism that GHC's coverage
+checker adheres to. Since the paper's publication, there have been some
+additional features added to the coverage checker which are not described in
+the paper. This Note serves as a reference for these new features.
+
+-----
+-- Strict argument type constraints
+-----
+
+In the ConVar case of clause processing, each conlike K traditionally
+generates two different forms of constraints:
+
+* A term constraint (e.g., x ~ K y1 ... yn)
+* Type constraints from the conlike's context (e.g., if K has type
+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)
+
+As it turns out, these alone are not enough to detect a certain class of
+unreachable code. Consider the following example (adapted from #15305):
+
+  data K = K1 | K2 !Void
+
+  f :: K -> ()
+  f K1 = ()
+
+Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?
+Because it's impossible to construct a terminating value of type `K` using the
+`K2` constructor, and thus it's impossible for `f` to ever successfully match
+on `K2`.
+
+The reason is because `K2`'s field of type `Void` is //strict//. Because there
+are no terminating values of type `Void`, any attempt to construct something
+using `K2` will immediately loop infinitely or throw an exception due to the
+strictness annotation. (If the field were not strict, then `f` could match on,
+say, `K2 undefined` or `K2 (let x = x in x)`.)
+
+Since neither the term nor type constraints mentioned above take strict
+argument types into account, we make use of the `nonVoid` function to
+determine whether a strict type is inhabitable by a terminating value or not.
+
+`nonVoid ty` returns True when either:
+1. `ty` has at least one InhabitationCandidate for which both its term and type
+   constraints are satifiable, and `nonVoid` returns `True` for all of the
+   strict argument types in that InhabitationCandidate.
+2. We're unsure if it's inhabited by a terminating value.
+
+`nonVoid ty` returns False when `ty` is definitely uninhabited by anything
+(except bottom). Some examples:
+
+* `nonVoid Void` returns False, since Void has no InhabitationCandidates.
+  (This is what lets us discard the `K2` constructor in the earlier example.)
+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate
+  (through the Refl constructor), and its term constraint (x ~ Refl) and
+  type constraint (Int ~ Int) are satisfiable.
+* `nonVoid (Int :~: Bool)` returns False. Although it has an
+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is
+  not satisfiable.
+* Given the following definition of `MyVoid`:
+
+    data MyVoid = MkMyVoid !Void
+
+  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid
+  constructor contains Void as a strict argument type, and since `nonVoid Void`
+  returns False, that InhabitationCandidate is discarded, leaving no others.
+
+* Performance considerations
+
+We must be careful when recursively calling `nonVoid` on the strict argument
+types of an InhabitationCandidate, because doing so naïvely can cause GHC to
+fall into an infinite loop. Consider the following example:
+
+  data Abyss = MkAbyss !Abyss
+
+  stareIntoTheAbyss :: Abyss -> a
+  stareIntoTheAbyss x = case x of {}
+
+In principle, stareIntoTheAbyss is exhaustive, since there is no way to
+construct a terminating value using MkAbyss. However, both the term and type
+constraints for MkAbyss are satisfiable, so the only way one could determine
+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.
+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term
+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`
+returns False... and now we've entered an infinite loop!
+
+To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the
+presence of recursive types (through `checkRecTc`), and if recursion is
+detected, we bail out and conservatively assume that the type is inhabited by
+some terminating value. This avoids infinite loops at the expense of making
+the coverage checker incomplete with respect to functions like
+stareIntoTheAbyss above. Then again, the same problem occurs with recursive
+newtypes, like in the following code:
+
+  newtype Chasm = MkChasm Chasm
+
+  gazeIntoTheChasm :: Chasm -> a
+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
+
+So this limitation is somewhat understandable.
+
+Note that even with this recursion detection, there is still a possibility that
+`nonVoid` can run in exponential time. Consider the following data type:
+
+  data T = MkT !T !T !T
+
+If we call `nonVoid` on each of its fields, that will require us to once again
+check if `MkT` is inhabitable in each of those three fields, which in turn will
+require us to check if `MkT` is inhabitable again... As you can see, the
+branching factor adds up quickly, and if the recursion depth limit is, say,
+100, then `nonVoid T` will effectively take forever.
+
+To mitigate this, we check the branching factor every time we are about to call
+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1
+(i.e., if there is potential for exponential runtime), then we limit the
+maximum recursion depth to 1 to mitigate the problem. If the branching factor
+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
+to stick with a larger maximum recursion depth.
+
+Another microoptimization applies to data types like this one:
+
+  data S a = ![a] !T
+
+Even though there is a strict field of type [a], it's quite silly to call
+nonVoid on it, since it's "obvious" that it is inhabitable. To make this
+intuition formal, we say that a type is definitely inhabitable (DI) if:
+
+  * It has at least one constructor C such that:
+    1. C has no equality constraints (since they might be unsatisfiable)
+    2. C has no strict argument types (since they might be uninhabitable)
+
+It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`
+on a list of strict argument types, we filter out all of the DI ones.
+-}
+
+instance Outputable InhabitationCandidate where
+  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct
+                             , ic_ty_cs = ty_cs
+                             , ic_strict_arg_tys = strict_arg_tys }) =
+    text "InhabitationCandidate" <+>
+      vcat [ text "ic_val_abs        =" <+> ppr va
+           , text "ic_tm_ct          =" <+> ppr tm_ct
+           , text "ic_ty_cs          =" <+> ppr ty_cs
+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]
+
+-- | Generate an 'InhabitationCandidate' for a given conlike (generate
 -- fresh variables of the appropriate type for arguments)
-mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)
+mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate
 --  *  x :: T tys, where T is an algebraic data type
 --     NB: in the case of a data family, T is the *representation* TyCon
 --     e.g.   data instance T (a,b) = T1 a b
@@ -962,28 +1575,32 @@ mkOneConFull :: Id -> ConLike -> DsM (ValAbs, ComplexEq, Bag EvVar)
 --            data TPair a b = T1 a b  -- The "representation" type
 --       It is TPair, not T, that is given to mkOneConFull
 --
---  * 'con' K is a constructor of data type T
+--  * 'con' K is a conlike of data type T
 --
 -- After instantiating the universal tyvars of K we get
 --          K tys :: forall bs. Q => s1 .. sn -> T tys
 --
--- Results: ValAbs:          K (y1::s1) .. (yn::sn)
---          ComplexEq:       x ~ K y1..yn
---          [EvVar]:         Q
+-- Suppose y1 is a strict field. Then we get
+-- Results: ic_val_abs:        K (y1::s1) .. (yn::sn)
+--          ic_tm_ct:          x ~ K y1..yn
+--          ic_ty_cs:          Q
+--          ic_strict_arg_tys: [s1]
 mkOneConFull x con = do
-  let -- res_ty == TyConApp (ConLikeTyCon cabs_con) cabs_arg_tys
-      res_ty  = idType x
-      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _)
+  let res_ty  = idType x
+      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)
         = conLikeFullSig con
-      tc_args = case splitTyConApp_maybe res_ty of
-                  Just (_, tys) -> tys
-                  Nothing -> pprPanic "mkOneConFull: Not TyConApp:" (ppr res_ty)
-      subst1  = zipTvSubst univ_tvs tc_args
+      arg_is_banged = map isBanged $ conLikeImplBangs con
+      tc_args = tyConAppArgs res_ty
+      subst1  = case con of
+                  RealDataCon {} -> zipTvSubst univ_tvs tc_args
+                  PatSynCon {}   -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)
+                                    -- See Note [Pattern synonym result type] in PatSyn
 
   (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
 
+  let arg_tys' = substTys subst arg_tys
   -- Fresh term variables (VAs) as arguments to the constructor
-  arguments <-  mapM mkPmVar (substTys subst arg_tys)
+  arguments <-  mapM mkPmVar arg_tys'
   -- All constraints bound by the constructor (alpha-renamed)
   let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)
   evvars <- mapM (nameType "pm") theta_cs
@@ -992,7 +1609,13 @@ mkOneConFull x con = do
                        , pm_con_tvs     = ex_tvs'
                        , pm_con_dicts   = evvars
                        , pm_con_args    = arguments }
-  return (con_abs, (PmExprVar (idName x), vaToPmExpr con_abs), listToBag evvars)
+      strict_arg_tys = filterByList arg_is_banged arg_tys'
+  return $ InhabitationCandidate
+           { ic_val_abs        = con_abs
+           , ic_tm_ct          = (PmExprVar (idName x), vaToPmExpr con_abs)
+           , ic_ty_cs          = listToBag evvars
+           , ic_strict_arg_tys = strict_arg_tys
+           }
 
 -- ----------------------------------------------------------------------------
 -- * More smart constructors and fresh variable generation
@@ -1046,7 +1669,7 @@ mkPmId ty = getUniqueM >>= \unique ->
 mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
 mkPmId2Forms ty = do
   x <- mkPmId ty
-  return (PmVar x, noLoc (HsVar (noLoc x)))
+  return (PmVar x, noLoc (HsVar noExt (noLoc x)))
 
 -- ----------------------------------------------------------------------------
 -- * Converting between Value Abstractions, Patterns and PmExpr
@@ -1093,30 +1716,94 @@ singleConstructor _ = False
 -- These come from two places.
 --  1. From data constructors defined with the result type constructor.
 --  2. From `COMPLETE` pragmas which have the same type as the result
---     type constructor.
+--     type constructor. Note that we only use `COMPLETE` pragmas
+--     *all* of whose pattern types match. See #14135
 allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
 allCompleteMatches cl tys = do
   let fam = case cl of
            RealDataCon dc ->
             [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
            PatSynCon _    -> []
-
-  pragmas <- case splitTyConApp_maybe (conLikeResTy cl tys) of
-              Just (tc, _) -> dsGetCompleteMatches tc
-              Nothing -> return []
-  let fams cm = fmap (FromComplete,) $
+      ty  = conLikeResTy cl tys
+  pragmas <- case splitTyConApp_maybe ty of
+               Just (tc, _) -> dsGetCompleteMatches tc
+               Nothing      -> return []
+  let fams cm = (FromComplete,) <$>
                 mapM dsLookupConLike (completeMatchConLikes cm)
-  from_pragma <- mapM fams pragmas
-
+  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>
+                mapM fams pragmas
   let final_groups = fam ++ from_pragma
-  tracePmD "allCompleteMatches" (ppr final_groups)
   return final_groups
+    where
+      -- Check that all the pattern synonym return types in a `COMPLETE`
+      -- pragma subsume the type we're matching.
+      -- See Note [Filtering out non-matching COMPLETE sets]
+      isValidCompleteMatch :: Type -> [ConLike] -> Bool
+      isValidCompleteMatch ty = all go
+        where
+          go (RealDataCon {}) = True
+          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy
+                                       $ patSynSig psc
+
+          patSynResTy (_, _, _, _, _, res_ty) = res_ty
+
+{-
+Note [Filtering out non-matching COMPLETE sets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, conlikes in a COMPLETE set are simply grouped by the
+type constructor heading the return type. This is nice and simple, but it does
+mean that there are scenarios when a COMPLETE set might be incompatible with
+the type of a scrutinee. For instance, consider (from #14135):
+
+  data Foo a = Foo1 a | Foo2 a
+
+  pattern MyFoo2 :: Int -> Foo Int
+  pattern MyFoo2 i = Foo2 i
+
+  {-# COMPLETE Foo1, MyFoo2 #-}
+
+  f :: Foo a -> a
+  f (Foo1 x) = x
+
+`f` has an incomplete pattern-match, so when choosing which constructors to
+report as unmatched in a warning, GHC must choose between the original set of
+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe
+that GHC shouldn't even consider the COMPLETE set as a possibility: the return
+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since
+there's no substitution `s` such that s(Foo Int) = Foo a.
+
+To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern
+synonym constructor's return type matches the type of the scrutinee, and if one
+doesn't, then we remove the whole COMPLETE set from consideration.
+
+One might wonder why GHC only checks /pattern synonym/ constructors, and not
+/data/ constructors as well. The reason is because that the type of a
+GADT constructor very well may not match the type of a scrutinee, and that's
+OK. Consider this example (from #14059):
+
+  data SBool (z :: Bool) where
+    SFalse :: SBool False
+    STrue  :: SBool True
+
+  pattern STooGoodToBeTrue :: forall (z :: Bool). ()
+                           => z ~ True
+                           => SBool z
+  pattern STooGoodToBeTrue = STrue
+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}
+
+  wobble :: SBool z -> Bool
+  wobble STooGoodToBeTrue = True
+
+In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse
+should be matched against, even though its type, SBool False, does not match
+the scrutinee type, SBool z.
+-}
 
 -- -----------------------------------------------------------------------
 -- * Types and constraints
 
 newEvVar :: Name -> Type -> EvVar
-newEvVar name ty = mkLocalId name (toTcType ty)
+newEvVar name ty = mkLocalId name ty
 
 nameType :: String -> Type -> DsM EvVar
 nameType name ty = do
@@ -1211,15 +1898,9 @@ runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
 -- delta with all term and type constraints in scope.
 mkInitialUncovered :: [Id] -> PmM Uncovered
 mkInitialUncovered vars = do
-  ty_cs  <- liftD getDictsDs
-  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs
-  sat_ty <- tyOracle ty_cs
-  let initTyCs = if sat_ty then ty_cs else emptyBag
-      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)
-      patterns  = map PmVar vars
-    -- If any of the term/type constraints are non
-    -- satisfiable then return with the initialTmState. See #12957
-  return [ValVec patterns (MkDelta initTyCs initTmState)]
+  delta <- pmInitialTmTyCs
+  let patterns = map PmVar vars
+  return [ValVec patterns delta]
 
 -- | Increase the counter for elapsed algorithm iterations, check that the
 -- limit is not exceeded and call `pmcheck`
@@ -1309,12 +1990,28 @@ pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
   | otherwise = return mempty
 
 -- ConCon
-pmcheckHd ( p@(PmCon {pm_con_con = c1, pm_con_args = args1})) ps guards
-          (va@(PmCon {pm_con_con = c2, pm_con_args = args2})) (ValVec vva delta)
+pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1
+                     , pm_con_args = args1})) ps guards
+          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2
+                     , pm_con_args = args2})) (ValVec vva delta)
   | c1 /= c2  =
     return (usimple [ValVec (va:vva) delta])
-  | otherwise = kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
-                <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta)
+  | otherwise = do
+    let to_evvar tv1 tv2 = nameType "pmConCon" $
+                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)
+        mb_to_evvar tv1 tv2
+            -- If we have identical constructors but different existential
+            -- tyvars, then generate extra equality constraints to ensure the
+            -- existential tyvars.
+            -- See Note [Coverage checking and existential tyvars].
+          | tv1 == tv2 = pure Nothing
+          | otherwise  = Just <$> to_evvar tv1 tv2
+    evvars <- (listToBag . catMaybes) <$>
+              ASSERT(ex_tvs1 `equalLength` ex_tvs2)
+              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)
+    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }
+    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
+      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')
 
 -- LitLit
 pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
@@ -1330,13 +2027,12 @@ pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
 
   cons_cs <- mapM (liftD . mkOneConFull x) complete_match
 
-  inst_vsa <- flip concatMapM cons_cs $ \(va, tm_ct, ty_cs) -> do
-    let ty_state = ty_cs `unionBags` delta_ty_cs delta -- not actually a state
-    sat_ty <- if isEmptyBag ty_cs then return True
-                                  else tyOracle ty_state
-    return $ case (sat_ty, solveOneEq (delta_tm_cs delta) tm_ct) of
-      (True, Just tm_state) -> [ValVec (va:vva) (MkDelta ty_state tm_state)]
-      _ty_or_tm_failed      -> []
+  inst_vsa <- flip mapMaybeM cons_cs $
+      \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                            , ic_ty_cs = ty_cs
+                            , ic_strict_arg_tys = strict_arg_tys } -> do
+    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys
+    pure $ fmap (ValVec (va:vva)) mb_sat
 
   set_provenance prov .
     force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
@@ -1405,6 +2101,121 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
 -- Impossible: handled by pmcheck
 pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
 
+{-
+Note [Coverage checking and existential tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC's implementation of the pattern-match coverage algorithm (as described in
+the GADTs Meet Their Match paper) must take some care to emit enough type
+constraints when handling data constructors with exisentially quantified type
+variables. To better explain what the challenge is, consider a constructor K
+of the form:
+
+  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p
+
+Where:
+
+* e_1, ..., e_m are the existentially bound type variables.
+* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type
+  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).
+* ty_1, ..., ty_n are the types of K's fields.
+* T u_1 ... u_p is the return type, where T is the data type constructor, and
+  u_1, ..., u_p are the universally quantified type variables.
+
+In the ConVar case, the coverage algorithm will have in hand the constructor
+K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p
+are some types that instantiate u_1, ... u_p. The idea is that we should
+substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the
+mkOneConFull function accomplishes this) and then hand this PmCon off to the
+ConCon case.
+
+The presence of existentially quantified type variables adds a significant
+wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,
+but we don't want them to appear in the final PmCon, because then
+calling (mkOneConFull K) for other pattern variables might reuse the same
+existential tyvars, which is certainly wrong.
+
+Previously, GHC's solution to this wrinkle was to always create fresh names
+for the existential tyvars and put them into the PmCon. This works well for
+many cases, but it can break down if you nest GADT pattern matches in just
+the right way. For instance, consider the following program:
+
+    data App f a where
+      App :: f a -> App f (Maybe a)
+
+    data Ty a where
+      TBool :: Ty Bool
+      TInt  :: Ty Int
+
+    data T f a where
+      C :: T Ty (Maybe Bool)
+
+    foo :: T f a -> App f a -> ()
+    foo C (App TBool) = ()
+
+foo is a total program, but with the previous approach to handling existential
+tyvars, GHC would mark foo's patterns as non-exhaustive.
+
+When foo is desugared to Core, it looks roughly like so:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()
+
+(Where `a1` is an existential tyvar.)
+
+That, in turn, is processed by the coverage checker to become:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))
+      | TBool <- pmvar123 |> co1
+      = ()
+
+Note that the type of pmvar123 is `f a1`—this will be important later.
+
+Now, we proceed with coverage-checking as usual. When we come to the
+ConVar case for App, we create a fresh variable `a2` to represent its
+existential tyvar. At this point, we have the equality constraints
+`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.
+
+However, when we check the guard, it will use the type of pmvar123, which is
+`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,
+it will generate the constraint `a1 ~ Int`. This means our final set of
+equality constraints would be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+
+Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,
+because GHC is unable to relate `a2` to `a1`, which really should be the same
+tyvar.
+
+Luckily, we can avoid this pitfall. Recall that the ConVar case was where we
+generated a PmCon with too-fresh existentials. But after ConVar, we have the
+ConCon case, which considers whether each constructor of a particular data type
+can be matched on in a particular spot.
+
+In the case of App, when we get to the ConCon case, we will compare our
+original App PmCon (from the source program) to the App PmCon created from the
+ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the
+existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here
+by emitting an additional `a1 ~ a2` constraint. Now our final set of equality
+constraints will be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+    a1 ~ a2
+
+Which is unsatisfiable, as we desired, since we now have that
+Int ~ a1 ~ a2 ~ Bool.
+
+In general, App might have more than one constructor, in which case we
+couldn't reuse the existential tyvar for App for a different constructor. This
+means that we can only use this trick in ConCon when the constructors are the
+same. But this is fine, since this is the only scenario where this situation
+arises in the first place!
+-}
+
 -- ----------------------------------------------------------------------------
 -- * Utilities for main checking
 
@@ -1470,7 +2281,7 @@ force_if True  pres = forces pres
 force_if False pres = pres
 
 set_provenance :: Provenance -> PartialResult -> PartialResult
-set_provenance prov pr = pr { presultProvenence = prov }
+set_provenance prov pr = pr { presultProvenance = prov }
 
 -- ----------------------------------------------------------------------------
 -- * Propagation of term constraints inwards when checking nested matches
@@ -1715,9 +2526,10 @@ exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
 exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
 exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag IfAlt         = Nothing
+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
 exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns
 exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
 exhaustiveWarningFlag ThPatSplice   = Nothing
@@ -1740,9 +2552,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
 
     (ppr_match, pref)
         = case kind of
-             FunRhs (L _ fun) _ _ -> (pprMatchContext kind,
-                                      \ pp -> ppr fun <+> pp)
-             _                    -> (pprMatchContext kind, \ pp -> pp)
+             FunRhs { mc_fun = L _ fun }
+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _    -> (pprMatchContext kind, \ pp -> pp)
 
 ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
 ppr_pats kind pats
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 16537bd7a5..99ba96755f 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -3,19 +3,17 @@
 (c) University of Glasgow, 2007
 -}
 
-{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}
+{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
 
 module Coverage (addTicksToBinds, hpcInitCode) where
 
+import GhcPrelude as Prelude
+
 import qualified GHCi
 import GHCi.RemoteTypes
 import Data.Array
 import ByteCodeTypes
-#if MIN_VERSION_base(4,9,0)
 import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
 import Type
 import HsSyn
 import Module
@@ -29,6 +27,7 @@ import NameSet hiding (FreeVars)
 import Name
 import Bag
 import CostCentre
+import CostCentreState
 import CoreSyn
 import Id
 import VarSet
@@ -36,7 +35,6 @@ import Data.List
 import FastString
 import HscTypes
 import TyCon
-import UniqSupply
 import BasicTypes
 import MonadUtils
 import Maybes
@@ -77,7 +75,6 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
     Just orig_file <- ml_hs_file mod_loc,
     not ("boot" `isSuffixOf` orig_file) = do
 
-     us <- mkSplitUniqSupply 'C' -- for cost centres
      let  orig_file2 = guessSourceFile binds orig_file
 
           tickPass tickish (binds,st) =
@@ -100,7 +97,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
 
           initState = TT { tickBoxCount = 0
                          , mixEntries   = []
-                         , uniqSupply   = us
+                         , ccIndices    = newCostCentreState
                          }
 
           (binds1,st) = foldr tickPass (binds, initState) passes
@@ -281,31 +278,6 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                       , isInlinePragma (idInlinePragma pid) ] }
 
-addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind
-                                        , abs_sig_export = poly_id }))
-  | L _ FunBind { fun_id = L _ mono_id } <- val_bind
-  = do withEnv (add_export  mono_id) $ do
-       withEnv (add_inlines mono_id) $ do
-       val_bind' <- addTickLHsBind val_bind
-       return $ L pos $ bind { abs_sig_bind = val_bind' }
-
-  | otherwise
-  = pprPanic "addTickLHsBind" (ppr bind)
- where
-  -- see AbsBinds comments
-  add_export mono_id env
-    | idName poly_id `elemNameSet` exports env
-    = env { exports = exports env `extendNameSet` idName mono_id }
-    | otherwise
-    = env
-
-  -- See Note [inline sccs]
-  add_inlines mono_id env
-    | isInlinePragma (idInlinePragma poly_id)
-    = env { inlines = inlines env `extendVarSet` mono_id }
-    | otherwise
-    = env
-
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   let name = getOccString id
   decl_path <- getPathEntry
@@ -320,11 +292,15 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
   tickish <- tickishType `liftM` getEnv
   if inline && tickish == ProfNotes then return (L pos funBind) else do
 
-  (fvs, mg@(MG { mg_alts = matches' })) <-
+  (fvs, mg) <-
         getFreeVars $
         addPathEntry name $
         addTickMatchGroup False (fun_matches funBind)
 
+  case mg of
+    MG {} -> return ()
+    _     -> panic "addTickLHsBind"
+
   blackListed <- isBlackListed pos
   exported_names <- liftM exports getEnv
 
@@ -343,7 +319,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
                 return Nothing
 
   let mbCons = maybe Prelude.id (:)
-  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
+  return $ L pos $ funBind { fun_matches = mg
                            , fun_tick = tick `mbCons` fun_tick funBind }
 
    where
@@ -379,6 +355,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
 
 
 bindTick
@@ -397,14 +374,7 @@ bindTick density name pos fvs = do
 
 -- Note [inline sccs]
 --
--- It should be reasonable to add ticks to INLINE functions; however
--- currently this tickles a bug later on because the SCCfinal pass
--- does not look inside unfoldings to find CostCentres.  It would be
--- difficult to fix that, because SCCfinal currently works on STG and
--- not Core (and since it also generates CostCentres for CAFs,
--- changing this would be difficult too).
---
--- Another reason not to add ticks to INLINE functions is that this
+-- The reason not to add ticks to INLINE functions is that this is
 -- sometimes handy for avoiding adding a tick to a particular function
 -- (see #6131)
 --
@@ -486,15 +456,15 @@ addTickLHsExprNever (L pos e0) = do
 -- general heuristic: expressions which do not denote values are good
 -- break points
 isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {})        = True
-isGoodBreakExpr (HsAppTypeOut {}) = True
-isGoodBreakExpr (OpApp {})        = True
-isGoodBreakExpr _other            = False
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr _other         = False
 
 isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{}        = True
-isCallSite HsAppTypeOut{} = True
-isCallSite OpApp{}        = True
+isCallSite HsApp{}     = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{}     = True
 isCallSite _ = False
 
 addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -516,55 +486,58 @@ addBinTickLHsExpr boxLabel (L pos e0)
 -- in the addTickLHsExpr family of functions.)
 
 addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut con)
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
   | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar _)      = return e
-addTickHsExpr e@(HsOverLit _)    = return e
-addTickHsExpr e@(HsOverLabel{})  = return e
-addTickHsExpr e@(HsLit _)        = return e
-addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
-                                                (addTickLHsExpr      e2)
-addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
-                                                        (return ty)
-
-addTickHsExpr (OpApp e1 e2 fix e3) =
+addTickHsExpr e@(HsIPVar {})       = return e
+addTickHsExpr e@(HsOverLit {})     = return e
+addTickHsExpr e@(HsOverLabel{})    = return e
+addTickHsExpr e@(HsLit {})         = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+                                           (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
+                                           (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
+                                                      (addTickLHsExpr      e2)
+addTickHsExpr (HsAppType ty e)   = liftM2 HsAppType (return ty)
+                                                    (addTickLHsExprNever e)
+
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
         liftM4 OpApp
+                (return fix)
                 (addTickLHsExpr e1)
                 (addTickLHsExprNever e2)
-                (return fix)
                 (addTickLHsExpr e3)
-addTickHsExpr (NegApp e neg) =
-        liftM2 NegApp
+addTickHsExpr (NegApp x e neg) =
+        liftM2 (NegApp x)
                 (addTickLHsExpr e)
                 (addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar e) =
-        liftM HsPar (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL e1 e2) =
-        liftM2 SectionL
+addTickHsExpr (HsPar x e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+        liftM2 (SectionL x)
                 (addTickLHsExpr e1)
                 (addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
-        liftM2 SectionR
+addTickHsExpr (SectionR x e1 e2) =
+        liftM2 (SectionR x)
                 (addTickLHsExprNever e1)
                 (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple es boxity) =
-        liftM2 ExplicitTuple
+addTickHsExpr (ExplicitTuple x es boxity) =
+        liftM2 (ExplicitTuple x)
                 (mapM addTickTupArg es)
                 (return boxity)
-addTickHsExpr (ExplicitSum tag arity e ty) = do
+addTickHsExpr (ExplicitSum ty tag arity e) = do
         e' <- addTickLHsExpr e
-        return (ExplicitSum tag arity e' ty)
-addTickHsExpr (HsCase e mgs) =
-        liftM2 HsCase
+        return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+        liftM2 (HsCase x)
                 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                    -- be evaluated.
                 (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf cnd e1 e2 e3) =
-        liftM3 (HsIf cnd)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+        liftM3 (HsIf x cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
@@ -572,14 +545,14 @@ addTickHsExpr (HsMultiIf ty alts)
   = do { let isOneOfMany = case alts of [_] -> False; _ -> True
        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
        ; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet (L l binds) e) =
+addTickHsExpr (HsLet x (L l binds) e) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsLet . L l)
+          liftM2 (HsLet x . L l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsExprLetBody e)
-addTickHsExpr (HsDo cxt (L l stmts) srcloc)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
-       ; return (HsDo cxt (L l stmts') srcloc) }
+       ; return (HsDo srcloc cxt (L l stmts')) }
   where
         forQual = case cxt of
                     ListComp -> Just $ BinBox QualBinBox
@@ -593,10 +566,6 @@ addTickHsExpr (ExplicitList ty wit es) =
                    addTickWit (Just fln)
                      = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
                           return (Just fln')
-addTickHsExpr (ExplicitPArr ty es) =
-        liftM2 ExplicitPArr
-                (return ty)
-                (mapM (addTickLHsExpr) es)
 
 addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
 
@@ -609,12 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
        ; flds' <- mapM addTickHsRecField flds
        ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
 
-addTickHsExpr (ExprWithTySig e ty) =
+addTickHsExpr (ExprWithTySig ty e) =
         liftM2 ExprWithTySig
-                (addTickLHsExprNever e) -- No need to tick the inner expression
-                                    -- for expressions with signatures
                 (return ty)
-addTickHsExpr (ArithSeq  ty wit arith_seq) =
+                (addTickLHsExprNever e) -- No need to tick the inner expression
+                                        -- for expressions with signatures
+addTickHsExpr (ArithSeq ty wit arith_seq) =
         liftM3 ArithSeq
                 (return ty)
                 (addTickWit wit)
@@ -624,26 +593,22 @@ addTickHsExpr (ArithSeq  ty wit arith_seq) =
                                              return (Just fl')
 
 -- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick t e) =
-        liftM (HsTick t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick t0 t1 e) =
-        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr (HsTick x t e) =
+        liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
-addTickHsExpr (PArrSeq   ty arith_seq) =
-        liftM2 PArrSeq
-                (return ty)
-                (addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC src nm e) =
-        liftM3 HsSCC
+addTickHsExpr (HsSCC x src nm e) =
+        liftM3 (HsSCC x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn src nm e) =
-        liftM3 HsCoreAnn
+addTickHsExpr (HsCoreAnn x src nm e) =
+        liftM3 (HsCoreAnn x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
@@ -651,27 +616,23 @@ addTickHsExpr e@(HsBracket     {})   = return e
 addTickHsExpr e@(HsTcBracketOut  {}) = return e
 addTickHsExpr e@(HsRnBracketOut  {}) = return e
 addTickHsExpr e@(HsSpliceE  {})      = return e
-addTickHsExpr (HsProc pat cmdtop) =
-        liftM2 HsProc
+addTickHsExpr (HsProc x pat cmdtop) =
+        liftM2 (HsProc x)
                 (addTickLPat pat)
                 (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
-        liftM2 HsWrap
+addTickHsExpr (HsWrap x w e) =
+        liftM2 (HsWrap x)
                 (return w)
                 (addTickHsExpr e)       -- Explicitly no tick on inside
 
-addTickHsExpr (ExprWithTySigOut e ty) =
-        liftM2 ExprWithTySigOut
-               (addTickLHsExprNever e) -- No need to tick the inner expression
-               (return ty)             -- for expressions with signatures
-
 -- Others should never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
 addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
-                                      ; return (L l (Present e')) }
+addTickTupArg (L l (Present x e))  = do { e' <- addTickLHsExpr e
+                                      ; return (L l (Present x e')) }
 addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg"
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                   -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
@@ -679,30 +640,34 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
   let isOneOfMany = matchesOneOfMany matches
   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
   return $ mg { mg_alts = L l matches' }
+addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
 
 addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
              -> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
+addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ Match mf pats opSig gRHSs'
+    return $ match { m_grhss = gRHSs' }
+addTickMatch _ _ (XMatch _) = panic "addTickMatch"
 
 addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
              -> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
   bindLocals binders $ do
     local_binds' <- addTickHsLocalBinds local_binds
     guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
-    return $ GRHSs guarded' (L l local_binds')
+    return $ GRHSs x guarded' (L l local_binds')
   where
     binders = collectLocalBinders local_binds
+addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
 
 addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
             -> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
                         (addTickGRHSBody isOneOfMany isLambda expr)
-  return $ GRHS stmts' expr'
+  return $ GRHS x stmts' expr'
+addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
 
 addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
@@ -732,36 +697,33 @@ addTickLStmts' isGuard lstmts res
 
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
             -> TM (Stmt GhcTc (LHsExpr GhcTc))
-addTickStmt _isGuard (LastStmt e noret ret) = do
-        liftM3 LastStmt
+addTickStmt _isGuard (LastStmt x e noret ret) = do
+        liftM3 (LastStmt x)
                 (addTickLHsExpr e)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
-        liftM5 BindStmt
+addTickStmt _isGuard (BindStmt x pat e bind fail) = do
+        liftM4 (BindStmt x)
                 (addTickLPat pat)
                 (addTickLHsExprRHS e)
                 (addTickSyntaxExpr hpcSrcSpan bind)
                 (addTickSyntaxExpr hpcSrcSpan fail)
-                (return ty)
-addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
-        liftM4 BodyStmt
+addTickStmt isGuard (BodyStmt x e bind' guard') = do
+        liftM3 (BodyStmt x)
                 (addTick isGuard e)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
-                (return ty)
-addTickStmt _isGuard (LetStmt (L l binds)) = do
-        liftM (LetStmt . L l)
+addTickStmt _isGuard (LetStmt x (L l binds)) = do
+        liftM (LetStmt x . L l)
                 (addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
-    liftM4 ParStmt
+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
+    liftM3 (ParStmt x)
         (mapM (addTickStmtAndBinders isGuard) pairs)
         (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
         (addTickSyntaxExpr hpcSrcSpan bindExpr)
-        (return ty)
-addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
     args' <- mapM (addTickApplicativeArg isGuard) args
-    return (ApplicativeStmt args' mb_join body_ty)
+    return (ApplicativeStmt body_ty args' mb_join)
 
 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                     , trS_by = by, trS_using = using
@@ -784,63 +746,75 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 
+addTickStmt _ (XStmtLR _) = panic "addTickStmt"
+
 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                   | otherwise          = addTickLHsExprRHS e
 
 addTickApplicativeArg
-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
 addTickApplicativeArg isGuard (op, arg) =
   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
  where
-  addTickArg (ApplicativeArgOne pat expr) =
-    ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr
-  addTickArg (ApplicativeArgMany stmts ret pat) =
-    ApplicativeArgMany
+  addTickArg (ApplicativeArgOne x pat expr isBody) =
+    (ApplicativeArgOne x)
+      <$> addTickLPat pat
+      <*> addTickLHsExpr expr
+      <*> pure isBody
+  addTickArg (ApplicativeArgMany x stmts ret pat) =
+    (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
       <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
       <*> addTickLPat pat
+  addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
 
 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                       -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
-    liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
         (addTickLStmts isGuard stmts)
         (return ids)
         (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
 
 addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
-addTickHsLocalBinds (HsValBinds binds) =
-        liftM HsValBinds
+addTickHsLocalBinds (HsValBinds x binds) =
+        liftM (HsValBinds x)
                 (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds binds)  =
-        liftM HsIPBinds
+addTickHsLocalBinds (HsIPBinds x binds)  =
+        liftM (HsIPBinds x)
                 (addTickHsIPBinds binds)
-addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
 
-addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
-addTickHsValBinds (ValBindsOut binds sigs) =
-        liftM2 ValBindsOut
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+                  -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+        b <- liftM2 NValBinds
                 (mapM (\ (rec,binds') ->
                                 liftM2 (,)
                                         (return rec)
                                         (addTickLHsBinds binds'))
                         binds)
                 (return sigs)
+        return $ XValBindsLR b
 addTickHsValBinds _ = panic "addTickHsValBinds"
 
 addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
-addTickHsIPBinds (IPBinds ipbinds dictbinds) =
+addTickHsIPBinds (IPBinds dictbinds ipbinds) =
         liftM2 IPBinds
-                (mapM (liftL (addTickIPBind)) ipbinds)
                 (return dictbinds)
+                (mapM (liftL (addTickIPBind)) ipbinds)
+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
 
 addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
-addTickIPBind (IPBind nm e) =
-        liftM2 IPBind
+addTickIPBind (IPBind x nm e) =
+        liftM2 (IPBind x)
                 (return nm)
                 (addTickLHsExpr e)
+addTickIPBind (XIPBind x) = return (XIPBind x)
 
 -- There is no location here, so we might need to use a context location??
 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
@@ -852,12 +826,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
 addTickLPat pat = return pat
 
 addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
-        liftM4 HsCmdTop
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
                 (addTickLHsCmd cmd)
-                (return tys)
-                (return ty)
-                (return syntaxtable)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
 
 addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
 addTickLHsCmd (L pos c0) = do
@@ -865,10 +838,10 @@ addTickLHsCmd (L pos c0) = do
         return $ L pos c1
 
 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam matchgroup) =
-        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp c e) =
-        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam x matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
 {-
 addTickHsCmd (OpApp e1 c2 fix c3) =
         liftM4 OpApp
@@ -877,41 +850,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
                 (return fix)
                 (addTickLHsCmd c3)
 -}
-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
-        liftM2 HsCmdCase
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+        liftM2 (HsCmdCase x)
                 (addTickLHsExpr e)
                 (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
-        liftM3 (HsCmdIf cnd)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+        liftM3 (HsCmdIf x cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsCmd c2)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet (L l binds) c) =
+addTickHsCmd (HsCmdLet x (L l binds) c) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsCmdLet . L l)
+          liftM2 (HsCmdLet x . L l)
                    (addTickHsLocalBinds binds) -- to think about: !patterns.
                    (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo (L l stmts') srcloc) }
+       ; return (HsCmdDo srcloc (L l stmts')) }
 
-addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
         liftM5 HsCmdArrApp
+               (return arr_ty)
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (return ty1)
-               (return arr_ty)
                (return lr)
-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
-        liftM4 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
                (addTickLHsExpr e)
                (return f)
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
-addTickHsCmd (HsCmdWrap w cmd)
-  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap x w cmd)
+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
 
 -- Others should never happen in a command context.
 --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
@@ -921,29 +896,33 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
 addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
   matches' <- mapM (liftL addTickCmdMatch) matches
   return $ mg { mg_alts = L l matches' }
+addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
 
 addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
-addTickCmdMatch (Match mf pats opSig gRHSs) =
+addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
   bindLocals (collectPatsBinders pats) $ do
     gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ Match mf pats opSig gRHSs'
+    return $ match { m_grhss = gRHSs' }
+addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
 
 addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
   bindLocals binders $ do
     local_binds' <- addTickHsLocalBinds local_binds
     guarded' <- mapM (liftL addTickCmdGRHS) guarded
-    return $ GRHSs guarded' (L l local_binds')
+    return $ GRHSs x guarded' (L l local_binds')
   where
     binders = collectLocalBinders local_binds
+addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
 
 addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
 -- The *guards* are *not* Cmds, although the body is
 -- C.f. addTickGRHS for the BinBox stuff
-addTickCmdGRHS (GRHS stmts cmd)
+addTickCmdGRHS (GRHS x stmts cmd)
   = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
                                    stmts (addTickLHsCmd cmd)
-       ; return $ GRHS stmts' expr' }
+       ; return $ GRHS x stmts' expr' }
+addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"
 
 addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
                  -> TM [LStmt GhcTc (LHsCmd GhcTc)]
@@ -962,26 +941,24 @@ addTickLCmdStmts' lstmts res
         binders = collectLStmtsBinders lstmts
 
 addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt pat c bind fail ty) = do
-        liftM5 BindStmt
+addTickCmdStmt (BindStmt x pat c bind fail) = do
+        liftM4 (BindStmt x)
                 (addTickLPat pat)
                 (addTickLHsCmd c)
                 (return bind)
                 (return fail)
-                (return ty)
-addTickCmdStmt (LastStmt c noret ret) = do
-        liftM3 LastStmt
+addTickCmdStmt (LastStmt x c noret ret) = do
+        liftM3 (LastStmt x)
                 (addTickLHsCmd c)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (BodyStmt c bind' guard' ty) = do
-        liftM4 BodyStmt
+addTickCmdStmt (BodyStmt x c bind' guard') = do
+        liftM3 (BodyStmt x)
                 (addTickLHsCmd c)
                 (addTickSyntaxExpr hpcSrcSpan bind')
                 (addTickSyntaxExpr hpcSrcSpan guard')
-                (return ty)
-addTickCmdStmt (LetStmt (L l binds)) = do
-        liftM (LetStmt . L l)
+addTickCmdStmt (LetStmt x (L l binds)) = do
+        liftM (LetStmt x . L l)
                 (addTickHsLocalBinds binds)
 addTickCmdStmt stmt@(RecStmt {})
   = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
@@ -992,6 +969,8 @@ addTickCmdStmt stmt@(RecStmt {})
                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 addTickCmdStmt ApplicativeStmt{} =
   panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+addTickCmdStmt XStmtLR{} =
+  panic "addTickCmdStmt XStmtLR"
 
 -- Others should never happen in a command context.
 addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
@@ -1033,7 +1012,7 @@ liftL f (L loc a) = do
 
 data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry_]
-                         , uniqSupply  :: UniqSupply
+                         , ccIndices   :: CostCentreState
                          }
 
 data TickTransEnv = TTE { fileName     :: FastString
@@ -1108,10 +1087,11 @@ instance Monad TM where
 instance HasDynFlags TM where
   getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
 
-instance MonadUnique TM where
-  getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)
-  getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)
-                             in (u, noFVs, st { uniqSupply = us' })
+-- | Get the next HPC cost centre index for a given centre name
+getCCIndexM :: FastString -> TM CostCentreIndex
+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
+                                                 ccIndices st
+                              in (idx, noFVs, st { ccIndices = is' })
 
 getState :: TM TickTransState
 getState = TM $ \ _ st -> (st, noFVs, st)
@@ -1191,7 +1171,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
     (fvs, e) <- getFreeVars m
     env <- getEnv
     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
-    return (L pos (HsTick tickish (L pos e)))
+    return (L pos (HsTick noExt tickish (L pos e)))
   ) (do
     e <- m
     return (L pos e)
@@ -1239,8 +1219,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
       return $ HpcTick (this_mod env) c
 
     ProfNotes -> do
-      ccUnique <- getUniqueM
-      let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique
+      let nm = mkFastString cc_name
+      flavour <- HpcCC <$> getCCIndexM nm
+      let cc = mkUserCC nm (this_mod env) pos flavour
           count = countEntries && gopt Opt_ProfCountEntries dflags
       return $ ProfNote cc count True{-scopes-}
 
@@ -1277,13 +1258,14 @@ mkBinTickBoxHpc boxLabel pos e =
       c = tickBoxCount st
       mes = mixEntries st
   in
-             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
-           -- notice that F and T are reversed,
-           -- because we are building the list in
-           -- reverse...
-             , noFVs
-             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
-             )
+     ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
+          $ L pos $ HsBinTick noExt (c+1) (c+2) e
+   -- notice that F and T are reversed,
+   -- because we are building the list in
+   -- reverse...
+     , noFVs
+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+     )
 
 mkHpcPos :: SrcSpan -> HpcPos
 mkHpcPos pos@(RealSrcSpan s)
@@ -1304,7 +1286,10 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 matchesOneOfMany :: [LMatch GhcTc body] -> Bool
 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
   where
-        matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss
+        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss
+        matchCount (L _ (Match { m_grhss = XGRHSs _ }))
+          = panic "matchesOneOfMany"
+        matchCount (L _ (XMatch _)) = panic "matchesOneOfMany"
 
 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 3d8a28f7b0..c1e728b734 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -16,6 +16,8 @@ module Desugar (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DsUsage
 import DynFlags
 import HscTypes
@@ -26,8 +28,6 @@ import TcRnDriver ( runTcInteractive )
 import Id
 import Name
 import Type
-import InstEnv
-import Class
 import Avail
 import CoreSyn
 import CoreFVs     ( exprsSomeFreeVarsList )
@@ -60,10 +60,12 @@ import Coverage
 import Util
 import MonadUtils
 import OrdList
+import ExtractDocs
 
 import Data.List
 import Data.IORef
 import Control.Monad( when )
+import Plugins ( LoadedPlugin(..) )
 
 {-
 ************************************************************************
@@ -101,7 +103,6 @@ deSugar hsc_env
                             tcg_th_foreign_files = th_foreign_files_var,
                             tcg_fords        = fords,
                             tcg_rules        = rules,
-                            tcg_vects        = vects,
                             tcg_patsyns      = patsyns,
                             tcg_tcs          = tcs,
                             tcg_insts        = insts,
@@ -131,24 +132,24 @@ deSugar hsc_env
                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
-                          ; ds_vects <- mapM dsVect vects
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
-                                   , spec_rules ++ ds_rules, ds_vects
+                                   , spec_rules ++ ds_rules
                                    , ds_fords `appendStubC` hpc_init) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) ->
+           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
 
      do {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
         ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
               final_prs = addExportFlagsAndRules target export_set keep_alive
-                                                 rules_for_locals (fromOL all_prs)
+                                                 mod rules_for_locals
+                                                 (fromOL all_prs)
 
               final_pgm = combineEvBinds ds_ev_binds final_prs
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -157,24 +158,25 @@ deSugar hsc_env
         -- You might think it doesn't matter, but the simplifier brings all top-level
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-#if defined(DEBUG)
-          -- Debug only as pre-simple-optimisation program may be really big
         ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
-#endif
-        ; (ds_binds, ds_rules_for_imps, ds_vects)
-            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
+        ; (ds_binds, ds_rules_for_imps)
+            <- simpleOptPgm dflags mod final_pgm rules_for_imps
                          -- The simpleOptPgm gets rid of type
                          -- bindings plus any stupid dead code
 
         ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
-        ; deps <- mkDependencies tcg_env
+              pluginModules =
+                map lpModule (plugins (hsc_dflags hsc_env))
+        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
+                                 (map mi_module pluginModules) tcg_env
 
         ; used_th <- readIORef tc_splice_used
         ; dep_files <- readIORef dependent_files
         ; safe_mode <- finalSafeMode dflags tcg_env
-        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
         -- id_mod /= mod when we are processing an hsig, but hsigs
         -- never desugared and compiled (there's no code!)
         -- Consequently, this should hold for any ModGuts that make
@@ -183,6 +185,8 @@ deSugar hsc_env
 
         ; foreign_files <- readIORef th_foreign_files_var
 
+        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
                 mg_hsc_src      = hsc_src,
@@ -207,11 +211,12 @@ deSugar hsc_env
                 mg_foreign_files = foreign_files,
                 mg_hpc_info     = ds_hpc_info,
                 mg_modBreaks    = modBreaks,
-                mg_vect_decls   = ds_vects,
-                mg_vect_info    = noVectInfo,
                 mg_safe_haskell = safe_mode,
                 mg_trust_pkg    = imp_trust_own_pkg imports,
-                mg_complete_sigs = complete_matches
+                mg_complete_sigs = complete_matches,
+                mg_doc_hdr      = doc_hdr,
+                mg_decl_docs    = decl_docs,
+                mg_arg_docs     = arg_docs
               }
         ; return (msgs, Just mod_guts)
         }}}}
@@ -244,7 +249,7 @@ Note [Top-level evidence]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Top-level evidence bindings may be mutually recursive with the top-level value
 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
-because the occurrence analyser doesn't teke account of type/coercion variables
+because the occurrence analyser doesn't take account of type/coercion variables
 when computing dependencies.
 
 So we pull out the type/coercion variables (which are in dependency order),
@@ -278,9 +283,9 @@ deSugarExpr hsc_env tc_expr = do {
 -}
 
 addExportFlagsAndRules
-    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    :: HscTarget -> NameSet -> NameSet -> Module -> [CoreRule]
     -> [(Id, t)] -> [(Id, t)]
-addExportFlagsAndRules target exports keep_alive rules prs
+addExportFlagsAndRules target exports keep_alive mod rules prs
   = mapFst add_one prs
   where
     add_one bndr = add_rules name (add_export name bndr)
@@ -313,10 +318,20 @@ addExportFlagsAndRules target exports keep_alive rules prs
         -- simplification), and retain them all in the TypeEnv so they are
         -- available from the command line.
         --
+        -- Most of the time, this can be accomplished by use of
+        -- targetRetainsAllBindings, which returns True if the target is
+        -- HscInteractive. However, there are cases when one can use GHCi with
+        -- a target other than HscInteractive (e.g., with the -fobject-code
+        -- flag enabled, as in #12091). In such scenarios,
+        -- targetRetainsAllBindings can return False, so we must fall back on
+        -- isInteractiveModule to be doubly sure we export entities defined in
+        -- a GHCi session.
+        --
         -- isExternalName separates the user-defined top-level names from those
         -- introduced by the type checker.
     is_exported :: Name -> Bool
-    is_exported | targetRetainsAllBindings target = isExternalName
+    is_exported | targetRetainsAllBindings target
+                  || isInteractiveModule mod      = isExternalName
                 | otherwise                       = (`elemNameSet` exports)
 
 {-
@@ -364,9 +379,9 @@ Reason
 -}
 
 dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
+dsRule (L loc (HsRule _ name rule_act vars lhs rhs))
   = putSrcSpanDs loc $
-    do  { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
+    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
 
         ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
                   unsetWOptM Opt_WarnIdentities $
@@ -379,7 +394,8 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
 
         -- Substitute the dict bindings eagerly,
         -- and take the body apart into a (f args) form
-        ; case decomposeRuleLhs bndrs'' lhs'' of {
+        ; dflags <- getDynFlags
+        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
                 Left msg -> do { warnDs NoReason msg; return Nothing } ;
                 Right (final_bndrs, fn_id, args) -> do
 
@@ -388,13 +404,12 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
                 -- we don't want to attach rules to the bindings of implicit Ids,
                 -- because they don't show up in the bindings until just before code gen
               fn_name   = idName fn_id
-              final_rhs = simpleOptExpr rhs''    -- De-crap it
+              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it
               rule_name = snd (unLoc name)
               final_bndrs_set = mkVarSet final_bndrs
               arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
                         exprsSomeFreeVarsList isId args
 
-        ; dflags <- getDynFlags
         ; rule <- dsMkUserRule this_mod is_local
                          rule_name rule_act fn_name final_bndrs args
                          final_rhs
@@ -403,6 +418,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
 
         ; return (Just rule)
         } } }
+dsRule (L _ (XRuleDecl _)) = panic "dsRule"
 
 
 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
@@ -424,7 +440,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
                                <+> text "might inline first")
                      , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
                        <+> quotes (ppr lhs_id)
-                     , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
+                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
 
       | check_rules_too
       , bad_rule : _ <- get_bad_rules lhs_id
@@ -435,7 +451,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids
                                <+> text "for"<+> quotes (ppr lhs_id)
                                <+> text "might fire first")
                       , text "Probable fix: add phase [n] or [~n] to the competing rule"
-                      , ifPprDebug (ppr bad_rule) ])
+                      , whenPprDebug (ppr bad_rule) ])
 
       | otherwise
       = return ()
@@ -531,38 +547,6 @@ about this. For example in Control.Arrow we have
 
 and similar, which will elicit exactly these warnings, and risk never
 firing.  But it's not clear what to do instead.  We could make the
-class methocd rules inactive in phase 2, but that would delay when
+class method rules inactive in phase 2, but that would delay when
 subsequent transformations could fire.
-
-
-************************************************************************
-*                                                                      *
-*              Desugaring vectorisation declarations
-*                                                                      *
-************************************************************************
 -}
-
-dsVect :: LVectDecl GhcTc -> DsM CoreVect
-dsVect (L loc (HsVect _ (L _ v) rhs))
-  = putSrcSpanDs loc $
-    do { rhs' <- dsLExpr rhs
-       ; return $ Vect v rhs'
-       }
-dsVect (L _loc (HsNoVect _ (L _ v)))
-  = return $ NoVect v
-dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
-  = return $ VectType isScalar tycon' rhs_tycon
-  where
-    tycon' | Just ty <- coreView $ mkTyConTy tycon
-           , (tycon', []) <- splitTyConApp ty      = tycon'
-           | otherwise                             = tycon
-dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
-  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
-dsVect (L _loc (HsVectClassOut cls))
-  = return $ VectClass (classTyCon cls)
-dsVect vc@(L _ (HsVectClassIn _ _))
-  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
-dsVect (L _loc (HsVectInstOut inst))
-  = return $ VectInst (instanceDFunId inst)
-dsVect vi@(L _ (HsVectInstIn _))
-  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index fb16d53e78..c69d7495d9 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -13,6 +13,8 @@ module DsArrows ( dsProcExpr ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Match
 import DsUtils
 import DsMonad
@@ -311,7 +313,7 @@ dsProcExpr
         :: LPat GhcTc
         -> LHsCmdTop GhcTc
         -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
     (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
@@ -326,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
                     (Lam var match_code)
                     core_cmd
     return (mkLets meth_binds proc_code)
+dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
 
 {-
 Translation of a command judgement of the form
@@ -361,7 +364,7 @@ dsCmd   :: DsCmdEnv             -- arrow combinators
 --              ---> premap (\ ((xs), _stk) -> arg) fun
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -386,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty
 --              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -414,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
     core_arg <- dsLExpr arg
     let
         arg_ty = exprType core_arg
@@ -447,8 +450,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _
-                                           (GRHSs [L _ (GRHS [] body)] _ ))] }))
+        (HsCmdLam _ (MG { mg_alts
+          = L _ [L _ (Match { m_pats  = pats
+                            , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })] }))
         env_ids = do
     let pat_vars = mkVarSet (collectPatsBinders pats)
     let
@@ -477,7 +481,7 @@ dsCmd ids local_vars stack_ty res_ty
     return (do_premap ids in_ty in_ty' res_ty select_code core_body,
             free_vars `udfmMinusUFM` getUniqSet pat_vars)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
 
 -- D, xs |- e :: Bool
@@ -490,7 +494,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
 --                       if e then Left ((xs1),stk) else Right ((xs2),stk))
 --                     (c1 ||| c2)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
         env_ids = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
@@ -551,8 +555,9 @@ case bodies, containing the following fields:
 -}
 
 dsCmd ids local_vars stack_ty res_ty
-      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
-                         , mg_origin = origin }))
+      (HsCmdCase _ exp (MG { mg_alts = L l matches
+                           , mg_ext = MatchGroupTc arg_tys _
+                           , mg_origin = origin }))
       env_ids = do
     stack_id <- newSysLocalDs stack_ty
 
@@ -573,10 +578,12 @@ dsCmd ids local_vars stack_ty res_ty
     left_con <- dsLookupDataCon leftDataConName
     right_con <- dsLookupDataCon rightDataConName
     let
-        left_id  = HsConLikeOut (RealDataCon left_con)
-        right_id = HsConLikeOut (RealDataCon right_con)
-        left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
-        right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+        left_id  = HsConLikeOut noExt (RealDataCon left_con)
+        right_id = HsConLikeOut noExt (RealDataCon right_con)
+        left_expr  ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+        right_expr ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
 
         -- Prefix each tuple with a distinct series of Left's and Right's,
         -- in a balanced way, keeping track of the types.
@@ -595,9 +602,10 @@ dsCmd ids local_vars stack_ty res_ty
         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
         in_ty = envStackType env_ids stack_ty
 
-    core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
-                                        , mg_arg_tys = arg_tys
-                                        , mg_res_ty = sum_ty, mg_origin = origin }))
+    core_body <- dsExpr (HsCase noExt exp
+                         (MG { mg_alts = L l matches'
+                             , mg_ext = MatchGroupTc arg_tys sum_ty
+                             , mg_origin = origin }))
         -- Note that we replace the HsCase result type by sum_ty,
         -- which is the type of matches'
 
@@ -611,7 +619,8 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+                                                                    env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
@@ -636,7 +645,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
 --
 --              ---> premap (\ (env,stk) -> env) c
 
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+                                                                   env_ids = do
     putSrcSpanDs loc $
       dsNoLevPoly stmts_ty
         (text "In the do-command:" <+> ppr do_block)
@@ -656,14 +666,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e
 -- -----------------------------------
 -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionDVarSets fv_sets)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
     core_wrap <- dsHsWrapper wrap
     return (core_wrap core_cmd, env_ids')
@@ -680,7 +690,8 @@ dsTrimCmdArg
         -> LHsCmdTop GhcTc       -- command argument to desugar
         -> DsM (CoreExpr,       -- desugared expression
                 DIdSet)         -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
+dsTrimCmdArg local_vars env_ids
+                       (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
     stack_id <- newSysLocalDs stack_ty
@@ -691,6 +702,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
         arg_code = if env_ids' == env_ids then core_cmd else
                 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
     return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
 
 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
@@ -748,7 +760,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 --
 --              ---> premap (\ (xs) -> ((xs), ())) c
 
-dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do
+dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
     putSrcSpanDs loc $ dsNoLevPoly res_ty
                          (text "In the command:" <+> ppr body)
     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
@@ -806,7 +818,7 @@ dsCmdStmt
 --              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
 --                      (first c >>> arr snd) >>> ss
 
-dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
+dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
     core_mux <- matchEnv env_ids
         (mkCorePairExpr
@@ -837,7 +849,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
 
-dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
     let pat_ty = hsLPatType pat
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
     let pat_vars = mkVarSet (collectPatBinders pat)
@@ -888,7 +900,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
 --
 --              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
 
-dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
+dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
     -- build a new environment using the let bindings
     core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
     -- match the old environment against the input
@@ -916,7 +928,8 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
 dsCmdStmt ids local_vars out_ids
         (RecStmt { recS_stmts = stmts
                  , recS_later_ids = later_ids, recS_rec_ids = rec_ids
-                 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
+                 , recS_ext = RecStmtTc { recS_later_rets = later_rets
+                                        , recS_rec_rets = rec_rets } })
         env_ids = do
     let
         later_ids_set = mkVarSet later_ids
@@ -1106,7 +1119,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
 
 leavesMatch :: LMatch GhcTc (Located (body GhcTc))
             -> [(Located (body GhcTc), IdSet)]
-leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
+leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) }))
   = let
         defined_vars = mkVarSet (collectPatsBinders pats)
                         `unionVarSet`
@@ -1115,7 +1128,9 @@ leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
     [(body,
       mkVarSet (collectLStmtsBinders stmts)
         `unionVarSet` defined_vars)
-    | L _ (GRHS stmts body) <- grhss]
+    | L _ (GRHS _ stmts body) <- grhss]
+leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch"
+leavesMatch (L _ (XMatch _)) = panic "leavesMatch"
 
 -- Replace the leaf commands in a match
 
@@ -1125,19 +1140,24 @@ replaceLeavesMatch
         -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command
         -> ([Located (body' GhcTc)],            -- remaining leaf expressions
             LMatch GhcTc (Located (body' GhcTc))) -- updated match
-replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves
+                        (L loc match@(Match { m_grhss = GRHSs x grhss binds }))
   = let
         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
-    (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))
+    (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
+replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _)))
+  = panic "replaceLeavesMatch"
+replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch"
 
 replaceLeavesGRHS
         :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type
         -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command
         -> ([Located (body' GhcTc)],              -- remaining leaf expressions
             LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
-  = (leaves, L loc (GRHS stmts leaf))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
+  = (leaves, L loc (GRHS x stmts leaf))
+replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS"
 replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
 
 -- Balanced fold of a non-empty list.
@@ -1185,31 +1205,30 @@ collectl :: LPat GhcTc -> [Id] -> [Id]
 collectl (L _ pat) bndrs
   = go pat
   where
-    go (VarPat (L _ var))         = var : bndrs
+    go (VarPat _ (L _ var))       = var : bndrs
     go (WildPat _)                = bndrs
-    go (LazyPat pat)              = collectl pat bndrs
-    go (BangPat pat)              = collectl pat bndrs
-    go (AsPat (L _ a) pat)        = a : collectl pat bndrs
-    go (ParPat  pat)              = collectl pat bndrs
+    go (LazyPat _ pat)            = collectl pat bndrs
+    go (BangPat _ pat)            = collectl pat bndrs
+    go (AsPat _ (L _ a) pat)      = a : collectl pat bndrs
+    go (ParPat _ pat)             = collectl pat bndrs
 
-    go (ListPat pats _ _)         = foldr collectl bndrs pats
-    go (PArrPat pats _)           = foldr collectl bndrs pats
-    go (TuplePat pats _ _)        = foldr collectl bndrs pats
-    go (SumPat pat _ _ _)         = collectl pat bndrs
+    go (ListPat _ pats)           = foldr collectl bndrs pats
+    go (TuplePat _ pats _)        = foldr collectl bndrs pats
+    go (SumPat _ pat _ _)         = collectl pat bndrs
 
     go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
                                     collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
-    go (LitPat _)                 = bndrs
+    go (LitPat _ _)               = bndrs
     go (NPat {})                  = bndrs
-    go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs
+    go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
 
-    go (SigPatIn pat _)           = collectl pat bndrs
-    go (SigPatOut pat _)          = collectl pat bndrs
-    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
-    go (ViewPat _ pat _)          = collectl pat bndrs
+    go (SigPat _ pat)             = collectl pat bndrs
+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
+    go (ViewPat _ _ pat)          = collectl pat bndrs
     go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
 
 collectEvBinders :: TcEvBinds -> [Id]
 collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5d9a33d660..421adcaccd 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -19,16 +19,18 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   DsExpr( dsLExpr )
 import {-# SOURCE #-}   Match( matchWrapper )
 
 import DsMonad
 import DsGRHSs
 import DsUtils
+import Check ( checkGuardMatches )
 
 import HsSyn            -- lots of things
 import CoreSyn          -- lots of things
-import Literal          ( Literal(MachStr) )
 import CoreOpt          ( simpleOptExpr )
 import OccurAnal        ( occurAnalyseExpr )
 import MkCore
@@ -47,11 +49,11 @@ import Coercion
 import TysWiredIn ( typeNatKind, typeSymbolKind )
 import Id
 import MkId(proxyHashId)
-import Class
 import Name
 import VarSet
 import Rules
 import VarEnv
+import Var( EvVar, varType )
 import Outputable
 import Module
 import SrcLoc
@@ -62,6 +64,7 @@ import BasicTypes
 import DynFlags
 import FastString
 import Util
+import UniqSet( nonDetEltsUniqSet )
 import MonadUtils
 import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad
@@ -79,7 +82,7 @@ dsTopLHsBinds binds
      -- see Note [Strict binds checks]
   | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
   = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
-       ; mapBagM_ (top_level_err "strict pattern bindings")    bang_binds
+       ; mapBagM_ (top_level_err "strict bindings")             bang_binds
        ; return nilOL }
 
   | otherwise
@@ -93,7 +96,7 @@ dsTopLHsBinds binds
 
   where
     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
-    bang_binds     = filterBag (isBangedPatBind  . unLoc) binds
+    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
 
     top_level_err desc (L loc bind)
       = putSrcSpanDs loc $
@@ -105,8 +108,7 @@ dsTopLHsBinds binds
 -- later be forced in the binding group body, see Note [Desugar Strict binds]
 dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
 dsLHsBinds binds
-  = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )
-       ; ds_bs <- mapBagM dsLHsBind binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
        ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
                          id ([], []) ds_bs) }
 
@@ -124,10 +126,9 @@ dsHsBind :: DynFlags
          -- binding group see Note [Desugar Strict binds] and all
          -- bindings and their desugared right hand sides.
 
-dsHsBind dflags
-         (VarBind { var_id = var
-                  , var_rhs = expr
-                  , var_inline = inline_regardless })
+dsHsBind dflags (VarBind { var_id = var
+                         , var_rhs = expr
+                         , var_inline = inline_regardless })
   = do  { core_expr <- dsLExpr expr
                 -- Dictionary bindings are always VarBinds,
                 -- so we only need do this here
@@ -139,9 +140,8 @@ dsHsBind dflags
                           else []
         ; return (force_var, [core_bind]) }
 
-dsHsBind dflags
-         b@(FunBind { fun_id = L _ fun, fun_matches = matches
-                    , fun_co_fn = co_fn, fun_tick = tick })
+dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
+                           , fun_co_fn = co_fn, fun_tick = tick })
  = do   { (args, body) <- matchWrapper
                            (mkPrefixFunRhs (noLoc $ idName fun))
                            Nothing matches
@@ -154,17 +154,20 @@ dsHsBind dflags
                 | xopt LangExt.Strict dflags
                 , matchGroupArity matches == 0 -- no need to force lambdas
                 = [id]
-                | isBangedBind b
+                | isBangedHsBind b
                 = [id]
                 | otherwise
                 = []
-        ; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $
-           return (force_var, [core_binds]) }
-
-dsHsBind dflags
-         (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
-                  , pat_ticks = (rhs_tick, var_ticks) })
+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
+          --                          , ppr (mg_alts matches)
+          --                          , ppr args, ppr core_binds]) $
+          return (force_var, [core_binds]) }
+
+dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
+                         , pat_ext = NPatBindTc _ ty
+                         , pat_ticks = (rhs_tick, var_ticks) })
   = do  { body_expr <- dsGuarded grhss ty
+        ; checkGuardMatches PatBindGuards grhss
         ; let body' = mkOptTickBox rhs_tick body_expr
               pat'  = decideBangHood dflags pat
         ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
@@ -175,47 +178,75 @@ dsHsBind dflags
                            else []
         ; return (force_var', sel_binds) }
 
-        -- A common case: one exported variable, only non-strict binds
-        -- Non-recursive bindings come through this way
-        -- So do self-recursive bindings
-        -- Bindings with complete signatures are AbsBindsSigs, below
-dsHsBind dflags
-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                   , abs_exports = [export]
-                   , abs_ev_binds = ev_binds, abs_binds = binds })
-  | ABE { abe_wrap = wrap, abe_poly = global
-        , abe_mono = local, abe_prags = prags } <- export
-  , not (xopt LangExt.Strict dflags)             -- Handle strict binds
-  , not (anyBag (isBangedBind . unLoc) binds)    --        in the next case
-  = -- See Note [AbsBinds wrappers] in HsBinds
-    addDictsDs (toTcTypeBag (listToBag dicts)) $
-         -- addDictsDs: push type constraints deeper for pattern match check
-    do { (force_vars, bind_prs) <- dsLHsBinds binds
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; core_wrap <- dsHsWrapper wrap -- Usually the identity
+dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                          , abs_exports = exports
+                          , abs_ev_binds = ev_binds
+                          , abs_binds = binds, abs_sig = has_sig })
+  = do { ds_binds <- addDictsDs (listToBag dicts) $
+                     dsLHsBinds binds
+                         -- addDictsDs: push type constraints deeper
+                         --             for inner pattern match check
+                         -- See Check, Note [Type and Term Equality Propagation]
+
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
+
+       -- dsAbsBinds does the hard work
+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
+
+
+-----------------------
+dsAbsBinds :: DynFlags
+           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+           -> [CoreBind]                -- Desugared evidence bindings
+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single binding with signature
+           -> DsM ([Id], [(Id,CoreExpr)])
+
+dsAbsBinds dflags tyvars dicts exports
+           ds_ev_binds (force_vars, bind_prs) has_sig
+
+    -- A very important common case: one exported variable
+    -- Non-recursive bindings come through this way
+    -- So do self-recursive bindings
+  | [export] <- exports
+  , ABE { abe_poly = global_id, abe_mono = local_id
+        , abe_wrap = wrap, abe_prags = prags } <- export
+  , Just force_vars' <- case force_vars of
+                           []                  -> Just []
+                           [v] | v == local_id -> Just [global_id]
+                           _                   -> Nothing
+       -- If there is a variable to force, it's just the
+       -- single variable we are binding here
+  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
 
        ; let rhs = core_wrap $
                    mkLams tyvars $ mkLams dicts $
-                   mkCoreLets ds_binds $
-                   mkLetRec bind_prs $
-                   Var local
+                   mkCoreLets ds_ev_binds $
+                   body
+
+             body | has_sig
+                  , [(_, lrhs)] <- bind_prs
+                  = lrhs
+                  | otherwise
+                  = mkLetRec bind_prs (Var local_id)
+
        ; (spec_binds, rules) <- dsSpecs rhs prags
 
-       ; let   global'  = addIdSpecialisations global rules
-               main_bind = makeCorePair dflags global' (isDefaultMethod prags)
-                                        (dictArity dicts) rhs
+       ; let global_id' = addIdSpecialisations global_id rules
+             main_bind  = makeCorePair dflags global_id'
+                                       (isDefaultMethod prags)
+                                       (dictArity dicts) rhs
 
-       ; ASSERT(null force_vars)
-         return ([], main_bind : fromOL spec_binds) }
+       ; return (force_vars', main_bind : fromOL spec_binds) }
 
-        -- Another common case: no tyvars, no dicts
-        -- In this case we can have a much simpler desugaring
-dsHsBind dflags
-         (AbsBinds { abs_tvs = [], abs_ev_vars = []
-                   , abs_exports = exports
-                   , abs_ev_binds = ev_binds, abs_binds = binds })
-  = do { (force_vars, bind_prs) <- dsLHsBinds binds
-       ; let mk_bind (ABE { abe_wrap = wrap
+    -- Another common case: no tyvars, no dicts
+    -- In this case we can have a much simpler desugaring
+  | null tyvars, null dicts
+
+  = do { let mk_bind (ABE { abe_wrap = wrap
                           , abe_poly = global
                           , abe_mono = local
                           , abe_prags = prags })
@@ -223,44 +254,38 @@ dsHsBind dflags
                    ; return (makeCorePair dflags global
                                           (isDefaultMethod prags)
                                           0 (core_wrap (Var local))) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
        ; main_binds <- mapM mk_bind exports
 
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) }
-
-dsHsBind dflags
-         (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                   , abs_exports = exports, abs_ev_binds = ev_binds
-                   , abs_binds = binds })
-         -- See Note [Desugaring AbsBinds]
-  = addDictsDs (toTcTypeBag (listToBag dicts)) $
-         -- addDictsDs: push type constraints deeper for pattern match check
-     do { (local_force_vars, bind_prs) <- dsLHsBinds binds
-        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
+       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+
+    -- The general case
+    -- See Note [Desugaring AbsBinds]
+  | otherwise
+  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
                               | (lcl_id, rhs) <- bind_prs ]
                 -- Monomorphic recursion possible, hence Rec
-              new_force_vars = get_new_force_vars local_force_vars
-              locals       = map abe_mono exports
-              all_locals   = locals ++ new_force_vars
-              tup_expr     = mkBigCoreVarTup all_locals
-              tup_ty       = exprType tup_expr
-        ; ds_binds <- dsTcEvBinds_s ev_binds
-        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
-                             mkCoreLets ds_binds $
-                             mkLet core_bind $
-                             tup_expr
-
-        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+             new_force_vars = get_new_force_vars force_vars
+             locals       = map abe_mono exports
+             all_locals   = locals ++ new_force_vars
+             tup_expr     = mkBigCoreVarTup all_locals
+             tup_ty       = exprType tup_expr
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_ev_binds $
+                            mkLet core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 
         -- Find corresponding global or make up a new one: sometimes
         -- we need to make new export to desugar strict binds, see
         -- Note [Desugar Strict binds]
-        ; (exported_force_vars, extra_exports) <- get_exports local_force_vars
+       ; (exported_force_vars, extra_exports) <- get_exports force_vars
 
-        ; let mk_bind (ABE { abe_wrap = wrap
-                           , abe_poly = global
-                           , abe_mono = local, abe_prags = spec_prags })
-                         -- See Note [AbsBinds wrappers] in HsBinds
+       ; let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local, abe_prags = spec_prags })
+                          -- See Note [AbsBinds wrappers] in HsBinds
                 = do { tup_id  <- newSysLocalDs tup_ty
                      ; core_wrap <- dsHsWrapper wrap
                      ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
@@ -274,11 +299,12 @@ dsHsBind dflags
                            -- the user written (local) function.  The global
                            -- Id is just the selector.  Hmm.
                      ; return ((global', rhs) : fromOL spec_binds) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
 
-        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
+       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
 
-        ; return (exported_force_vars
-                 ,(poly_tup_id, poly_tup_rhs) :
+       ; return ( exported_force_vars
+                , (poly_tup_id, poly_tup_rhs) :
                    concat export_binds_s) }
   where
     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
@@ -321,57 +347,11 @@ dsHsBind dflags
     mk_export local =
       do global <- newSysLocalDs
                      (exprType (mkLams tyvars (mkLams dicts (Var local))))
-         return (ABE {abe_poly = global
-                     ,abe_mono = local
-                     ,abe_wrap = WpHole
-                     ,abe_prags = SpecPrags []})
-
--- AbsBindsSig is a combination of AbsBinds and FunBind
-dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
-                             , abs_sig_export  = global
-                             , abs_sig_prags   = prags
-                             , abs_sig_ev_bind = ev_bind
-                             , abs_sig_bind    = bind })
-  | L bind_loc FunBind { fun_matches = matches
-                       , fun_co_fn   = co_fn
-                       , fun_tick    = tick } <- bind
-  = putSrcSpanDs bind_loc $
-    addDictsDs (toTcTypeBag (listToBag dicts)) $
-             -- addDictsDs: push type constraints deeper for pattern match check
-    do { (args, body) <- matchWrapper
-                           (mkPrefixFunRhs (noLoc $ idName global))
-                           Nothing matches
-       ; core_wrap <- dsHsWrapper co_fn
-       ; let body'   = mkOptTickBox tick body
-             fun_rhs = core_wrap (mkLams args body')
-             force_vars
-               | xopt LangExt.Strict dflags
-               , matchGroupArity matches == 0 -- no need to force lambdas
-               = [global]
-               | isBangedBind (unLoc bind)
-               = [global]
-               | otherwise
-               = []
-
-       ; ds_binds <- dsTcEvBinds ev_bind
-       ; let rhs = mkLams tyvars $
-                   mkLams dicts $
-                   mkCoreLets ds_binds $
-                   fun_rhs
-
-       ; (spec_binds, rules) <- dsSpecs rhs prags
-       ; let global' = addIdSpecialisations global rules
-             main_bind = makeCorePair dflags global' (isDefaultMethod prags)
-                                      (dictArity dicts) rhs
-
-       ; return (force_vars, main_bind : fromOL spec_binds) }
-
-  | otherwise
-  = pprPanic "dsHsBind: AbsBindsSig" (ppr bind)
-
-dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-
-
+         return (ABE { abe_ext   = noExt
+                     , abe_poly  = global
+                     , abe_mono  = local
+                     , abe_wrap  = WpHole
+                     , abe_prags = SpecPrags [] })
 
 -- | This is where we apply INLINE and INLINABLE pragmas. All we need to
 -- do is to attach the unfolding information to the Id.
@@ -384,15 +364,16 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
              -> (Id, CoreExpr)
 makeCorePair dflags gbl_id is_default_method dict_arity rhs
-  | is_default_method                 -- Default methods are *always* inlined
+  | is_default_method    -- Default methods are *always* inlined
+                         -- See Note [INLINE and default methods] in TcInstDcls
   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 
   | otherwise
   = case inlinePragmaSpec inline_prag of
-          EmptyInlineSpec -> (gbl_id, rhs)
-          NoInline        -> (gbl_id, rhs)
-          Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
-          Inline          -> inline_pair
+          NoUserInline -> (gbl_id, rhs)
+          NoInline     -> (gbl_id, rhs)
+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline       -> inline_pair
 
   where
     inline_prag   = idInlinePragma gbl_id
@@ -631,7 +612,7 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
 
 is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
 
-Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind.
+Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.
 Define a "strict bind" to be either an unlifted bind or a banged bind.
 
 The restrictions are:
@@ -680,7 +661,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   = putSrcSpanDs loc $
     do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
                           <+> quotes (ppr poly_id))
-       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
+       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
                             -- See Note [Activation pragmas for SPECIALISE]
 
   | otherwise
@@ -702,14 +683,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
          --                         , text "spec_co:" <+> ppr spec_co
          --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
-         case decomposeRuleLhs spec_bndrs ds_lhs of {
+         dflags <- getDynFlags
+       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
            Left msg -> do { warnDs NoReason msg; return Nothing } ;
            Right (rule_bndrs, _fn, args) -> do
 
-       { dflags <- getDynFlags
-       ; this_mod <- getModule
+       { this_mod <- getModule
        ; let fn_unf    = realIdUnfolding poly_id
-             spec_unf  = specUnfolding spec_bndrs core_app arity_decrease fn_unf
+             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
              spec_id   = mkLocalId spec_name spec_ty
                             `setInlinePragma` inl_prag
                             `setIdUnfolding`  spec_unf
@@ -841,14 +822,15 @@ SPEC f :: ty                [n]   INLINE [k]
 ************************************************************************
 -}
 
-decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
+decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
+                 -> Either SDoc ([Var], Id, [CoreExpr])
 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
 -- may add some extra dictionary binders (see Note [Free dictionaries])
 --
 -- Returns an error message if the LHS isn't of the expected shape
 -- Note [Decomposing the left-hand side of a RULE]
-decomposeRuleLhs orig_bndrs orig_lhs
+decomposeRuleLhs dflags orig_bndrs orig_lhs
   | not (null unbound)    -- Check for things unbound on LHS
                           -- See Note [Unused spec binders]
   = Left (vcat (map dead_msg unbound))
@@ -869,7 +851,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
   = Left bad_shape_msg
  where
    lhs1         = drop_dicts orig_lhs
-   lhs2         = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]
+   lhs2         = simpleOptExpr dflags lhs1  -- See Note [Simplify rule LHS]
    (fun2,args2) = collectArgs lhs2
 
    lhs_fvs    = exprFreeVars lhs2
@@ -1040,7 +1022,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
              RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
                 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
 
-   Trac #8848 is a good example of where there are some intersting
+   Trac #8848 is a good example of where there are some interesting
    dictionary bindings to discard.
 
 The drop_dicts algorithm is based on these observations:
@@ -1165,15 +1147,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 
 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
+dsEvBinds bs
+  = do { ds_bs <- mapBagM dsEvBind bs
+       ; return (mk_ev_binds ds_bs) }
+
+mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
+-- We do SCC analysis of the evidence bindings, /after/ desugaring
+-- them. This is convenient: it means we can use the CoreSyn
+-- free-variable functions rather than having to do accurate free vars
+-- for EvTerm.
+mk_ev_binds ds_binds
+  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
   where
-    ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r}))
-                          = liftM (NonRec v) (dsEvTerm r)
-    ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs)
+    edges :: [ Node EvVar (EvVar,CoreExpr) ]
+    edges = foldrBag ((:) . mk_node) [] ds_binds
+
+    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
+    mk_node b@(var, rhs)
+      = DigraphNode { node_payload = b
+                    , node_key = var
+                    , node_dependencies = nonDetEltsUniqSet $
+                                          exprFreeVars rhs `unionVarSet`
+                                          coVarsOfType (varType var) }
+      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
+      -- is still deterministic even if the edges are in nondeterministic order
+      -- as explained in Note [Deterministic SCC] in Digraph.
+
+    ds_scc (AcyclicSCC (v,r)) = NonRec v r
+    ds_scc (CyclicSCC prs)    = Rec prs
 
 dsEvBind :: EvBind -> DsM (Id, CoreExpr)
 dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
 
+
 {-**********************************************************************
 *                                                                      *
            Desugaring EvTerms
@@ -1181,41 +1187,15 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
 **********************************************************************-}
 
 dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvId v)           = return (Var v)
-dsEvTerm (EvCallStack cs)   = dsEvCallStack cs
-dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
-dsEvTerm (EvLit (EvNum n))  = mkNaturalExpr n
-dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s
-
-dsEvTerm (EvCast tm co)
-  = do { tm' <- dsEvTerm tm
-       ; return $ mkCastDs tm' co }
-
-dsEvTerm (EvDFunApp df tys tms)
-  = do { tms' <- mapM dsEvTerm tms
-       ; return $ Var df `mkTyApps` tys `mkApps` tms' }
-  -- The use of mkApps here is OK vis-a-vis levity polymorphism because
-  -- the terms are always evidence variables with types of kind Constraint
-
-dsEvTerm (EvCoercion co) = return (Coercion co)
-dsEvTerm (EvSuperClass d n)
-  = do { d' <- dsEvTerm d
-       ; let (cls, tys) = getClassPredTys (exprType d')
-             sc_sel_id  = classSCSelId cls n    -- Zero-indexed
-       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
-
-dsEvTerm (EvSelector sel_id tys tms)
-  = do { tms' <- mapM dsEvTerm tms
-       ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
-
-dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
-
-dsEvDelayedError :: Type -> FastString -> CoreExpr
-dsEvDelayedError ty msg
-  = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg]
-  where
-    errorId = tYPE_ERROR_ID
-    litMsg  = Lit (MachStr (fastStringToByteString msg))
+dsEvTerm (EvExpr e)          = return e
+dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
+dsEvTerm (EvFun { et_tvs = tvs, et_given = given
+                , et_binds = ev_binds, et_body = wanted_id })
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; return $ (mkLams (tvs ++ given) $
+                   mkCoreLets ds_ev_binds $
+                   Var wanted_id) }
+
 
 {-**********************************************************************
 *                                                                      *
@@ -1264,10 +1244,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
          -- Note that we use the kind of the type, not the TyCon from which it
          -- is constructed since the latter may be kind polymorphic whereas the
          -- former we know is not (we checked in the solver).
-       ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty)
-                                       , Type ty
-                                       , tc_rep
-                                       , kind_args ]
+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+                                         , Type ty
+                                         , tc_rep
+                                         , kind_args ]
+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+       ; return expr
        }
 
 ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
@@ -1278,8 +1260,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
                     -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
                     --            TypeRep a -> TypeRep b -> TypeRep (a b)
        ; let (k1, k2) = splitFunTy (typeKind t1)
-       ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
-                         [ e1, e2 ] }
+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+                            [ e1, e2 ]
+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+       ; return expr
+       }
 
 ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
   | Just (t1,t2) <- splitFunTy_maybe ty
@@ -1288,15 +1273,16 @@ ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
        ; mkTrFun <- dsLookupGlobalId mkTrFunName
                     -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
                     --            TypeRep a -> TypeRep b -> TypeRep (a -> b)
-       ; let r1 = getRuntimeRep "ds_ev_typeable" t1
-             r2 = getRuntimeRep "ds_ev_typeable" t2
+       ; let r1 = getRuntimeRep t1
+             r2 = getRuntimeRep t2
        ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
                          [ e1, e2 ]
        }
 
 ds_ev_typeable ty (EvTypeableTyLit ev)
-  = do { fun  <- dsLookupGlobalId tr_fun
-       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSym
+  = -- See Note [Typeable for Nat and Symbol] in TcInteract
+    do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
        ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
        ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
   where
@@ -1332,58 +1318,3 @@ tyConRep tc
        ; return (Var tc_rep_id) }
   | otherwise
   = pprPanic "tyConRep" (ppr tc)
-
-{- Note [Memoising typeOf]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #3245, #9203
-
-IMPORTANT: we don't want to recalculate the TypeRep once per call with
-the proxy argument.  This is what went wrong in #3245 and #9203. So we
-help GHC by manually keeping the 'rep' *outside* the lambda.
--}
-
-
-{-**********************************************************************
-*                                                                      *
-           Desugaring EvCallStack evidence
-*                                                                      *
-**********************************************************************-}
-
-dsEvCallStack :: EvCallStack -> DsM CoreExpr
--- See Note [Overview of implicit CallStacks] in TcEvidence.hs
-dsEvCallStack cs = do
-  df            <- getDynFlags
-  m             <- getModule
-  srcLocDataCon <- dsLookupDataCon srcLocDataConName
-  let mkSrcLoc l =
-        liftM (mkCoreConApps srcLocDataCon)
-              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
-                        , mkStringExprFS (moduleNameFS $ moduleName m)
-                        , mkStringExprFS (srcSpanFile l)
-                        , return $ mkIntExprInt df (srcSpanStartLine l)
-                        , return $ mkIntExprInt df (srcSpanStartCol l)
-                        , return $ mkIntExprInt df (srcSpanEndLine l)
-                        , return $ mkIntExprInt df (srcSpanEndCol l)
-                        ])
-
-  emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName
-
-  pushCSVar <- dsLookupGlobalId pushCallStackName
-  let pushCS name loc rest =
-        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
-
-  let mkPush name loc tm = do
-        nameExpr <- mkStringExprFS name
-        locExpr <- mkSrcLoc loc
-        case tm of
-          EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
-          _ -> do tmExpr  <- dsEvTerm tm
-                  -- at this point tmExpr :: IP sym CallStack
-                  -- but we need the actual CallStack to pass to pushCS,
-                  -- so we use unwrapIP to strip the dictionary wrapper
-                  -- See Note [Overview of implicit CallStacks]
-                  let ip_co = unwrapIP (exprType tmExpr)
-                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
-  case cs of
-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
-    EvCsEmpty -> return emptyCS
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
index 2a5769f6e2..7a634ac1ff 100644
--- a/compiler/deSugar/DsCCall.hs
+++ b/compiler/deSugar/DsCCall.hs
@@ -18,6 +18,8 @@ module DsCCall
 #include "HsVersions.h"
 
 
+import GhcPrelude
+
 import CoreSyn
 
 import DsMonad
@@ -134,7 +136,7 @@ unboxArg :: CoreExpr                    -- The supplied argument, not levity-pol
 -- always returns a non-levity-polymorphic expression
 
 unboxArg arg
-  -- Primtive types: nothing to unbox
+  -- Primitive types: nothing to unbox
   | isPrimitiveType arg_ty
   = return (arg, \body -> body)
 
@@ -202,7 +204,7 @@ boxResult :: Type
 
 -- Takes the result of the user-level ccall:
 --      either (IO t),
---      or maybe just t for an side-effect-free call
+--      or maybe just t for a side-effect-free call
 -- Returns a wrapper for the primitive ccall itself, along with the
 -- type of the result of the primitive ccall.  This result type
 -- will be of the form
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index c3d9489476..f9ee3b4cb8 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -14,6 +14,8 @@ module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Match
 import MatchLit
 import DsBinds
@@ -22,6 +24,7 @@ import DsListComp
 import DsUtils
 import DsArrows
 import DsMonad
+import Check ( checkGuardMatches )
 import Name
 import NameEnv
 import FamInstEnv( topNormaliseType )
@@ -68,29 +71,33 @@ import Control.Monad
 -}
 
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (L _   EmptyLocalBinds)    body = return body
-dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
-                                               dsValBinds binds body
-dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
+dsLocalBinds (L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+                                                   dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds (L _ (XHsLocalBindsLR _))    _    = panic "dsLocalBinds"
 
 -------------------------
 -- caller sets location
 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
-dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+  = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
 
 -------------------------
 dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds ev_binds) body
+dsIPBinds (IPBinds ev_binds ip_binds) body
   = do  { ds_binds <- dsTcEvBinds ev_binds
         ; let inner = mkCoreLets ds_binds body
                 -- The dict bindings may not be in
                 -- dependency order; hence Rec
         ; foldrM ds_ip_bind inner ip_binds }
   where
-    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
+    ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
       = do e' <- dsLExpr e
            return (Let (NonRec n e') body)
+    ds_ip_bind (L _ (XIPBind _)) _ = panic "dsIPBinds"
+dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
 
 -------------------------
 -- caller sets location
@@ -130,8 +137,6 @@ ds_val_bind (NonRecursive, hsbinds) body
   where
     is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
                      = not (null tvs && null evs)
-    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
-                     = not (null tvs && null evs)
     is_polymorphic _ = False
 
     unlifted_must_be_bang bind
@@ -186,15 +191,6 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
        ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
-dsUnliftedBind (AbsBindsSig { abs_tvs         = []
-                            , abs_ev_vars     = []
-                            , abs_sig_export  = poly
-                            , abs_sig_ev_bind = ev_bind
-                            , abs_sig_bind    = L _ bind }) body
-  = do { ds_binds <- dsTcEvBinds ev_bind
-       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
-       ; return (mkCoreLets ds_binds body') }
-
 dsUnliftedBind (FunBind { fun_id = L l fun
                         , fun_matches = matches
                         , fun_co_fn = co_fn
@@ -208,10 +204,12 @@ dsUnliftedBind (FunBind { fun_id = L l fun
        ; let rhs' = mkOptTickBox tick rhs
        ; return (bindNonRec fun rhs' body) }
 
-dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
+                        , pat_ext = NPatBindTc _ ty }) body
   =     -- let C x# y# = rhs in body
         -- ==> case rhs of C x# y# -> body
     do { rhs <- dsGuarded grhss ty
+       ; checkGuardMatches PatBindGuards grhss
        ; let upat = unLoc pat
              eqn = EqnInfo { eqn_pats = [upat],
                              eqn_rhs = cantFailMatchResult body }
@@ -258,18 +256,19 @@ dsExpr = ds_expr False
 ds_expr :: Bool   -- are we directly inside an HsWrap?
                   -- See Wrinkle in Note [Detecting forced eta expansion]
         -> HsExpr GhcTc -> DsM CoreExpr
-ds_expr _ (HsPar e)              = dsLExpr e
-ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
-ds_expr w (HsVar (L _ var))      = dsHsVar w var
+ds_expr _ (HsPar _ e)            = dsLExpr e
+ds_expr _ (ExprWithTySig _ e)    = dsLExpr e
+ds_expr w (HsVar _ (L _ var))    = dsHsVar w var
 ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-ds_expr w (HsConLikeOut con)     = dsConLike w con
-ds_expr _ (HsIPVar _)            = panic "dsExpr: HsIPVar"
+ds_expr w (HsConLikeOut _ con)   = dsConLike w con
+ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"
 ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
-ds_expr _ (HsLit lit)            = dsLit (convertLit lit)
-ds_expr _ (HsOverLit lit)        = dsOverLit lit
+ds_expr _ (HsLit _ lit)          = dsLit (convertLit lit)
+ds_expr _ (HsOverLit _ lit)      = dsOverLit lit
 
-ds_expr _ (HsWrap co_fn e)
-  = do { e' <- ds_expr True e
+ds_expr _ (HsWrap _ co_fn e)
+  = do { e' <- ds_expr True e    -- This is the one place where we recurse to
+                                 -- ds_expr (passing True), rather than dsExpr
        ; wrap' <- dsHsWrapper co_fn
        ; dflags <- getDynFlags
        ; let wrapped_e = wrap' e'
@@ -278,7 +277,7 @@ ds_expr _ (HsWrap co_fn e)
        ; warnAboutIdentities dflags e' wrapped_ty
        ; return wrapped_e }
 
-ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
+ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
                   neg_expr)
   = do { expr' <- putSrcSpanDs loc $ do
           { dflags <- getDynFlags
@@ -287,27 +286,26 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
           ; dsOverLit' dflags lit }
        ; dsSyntaxExpr neg_expr [expr'] }
 
-ds_expr _ (NegApp expr neg_expr)
+ds_expr _ (NegApp _ expr neg_expr)
   = do { expr' <- dsLExpr expr
        ; dsSyntaxExpr neg_expr [expr'] }
 
-ds_expr _ (HsLam a_Match)
+ds_expr _ (HsLam _ a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
 
-ds_expr _ (HsLamCase matches)
+ds_expr _ (HsLamCase _ matches)
   = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
        ; return $ Lam discrim_var matching_code }
 
-ds_expr _ e@(HsApp fun arg)
+ds_expr _ e@(HsApp _ fun arg)
   = do { fun' <- dsLExpr fun
        ; dsWhenNoErrs (dsLExprNoLP arg)
                       (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
 
-ds_expr _ (HsAppTypeOut e _)
+ds_expr _ (HsAppType _ e)
     -- ignore type arguments here; they're in the wrappers instead at this point
   = dsLExpr e
 
-
 {-
 Note [Desugaring vars]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -347,19 +345,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier
 will sort it out.
 -}
 
-ds_expr _ e@(OpApp e1 op _ e2)
+ds_expr _ e@(OpApp _ e1 op e2)
   = -- for the type of y, we need the type of op's 2nd argument
     do { op' <- dsLExpr op
        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
                       (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
 
-ds_expr _ (SectionL expr op)       -- Desugar (e !) to ((!) e)
+ds_expr _ (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
   = do { op' <- dsLExpr op
        ; dsWhenNoErrs (dsLExprNoLP expr)
                       (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
-ds_expr _ e@(SectionR op expr) = do
+ds_expr _ e@(SectionR _ op expr) = do
     core_op <- dsLExpr op
     -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -370,67 +368,67 @@ ds_expr _ e@(SectionR op expr) = do
                                    Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
                                                           core_op [Var x_id, Var y_id]))
 
-ds_expr _ (ExplicitTuple tup_args boxity)
+ds_expr _ (ExplicitTuple _ tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
                     -- For every missing expression, we need
                     -- another lambda in the desugaring.
                = do { lam_var <- newSysLocalDsNoLP ty
                     ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (L _ (Present expr))
+             go (lam_vars, args) (L _ (Present _ expr))
                     -- Expressions that are present don't generate
                     -- lambdas, just arguments.
-               = do { core_expr <- dsLExpr expr
+               = do { core_expr <- dsLExprNoLP expr
                     ; return (lam_vars, core_expr : args) }
+             go _ (L _ (XTupArg {})) = panic "ds_expr"
 
-       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
+       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
+                      (\(lam_vars, args) -> mkCoreLams lam_vars $
+                                            mkCoreTupBoxity boxity args) }
 
-       ; return $ mkCoreLams lam_vars $
-                  mkCoreTupBoxity boxity args }
-
-ds_expr _ (ExplicitSum alt arity expr types)
-  = do { core_expr <- dsLExpr expr
-       ; return $ mkCoreConApps (sumDataCon alt arity)
-                                (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++
-                                 map Type types ++
-                                 [core_expr]) }
+ds_expr _ (ExplicitSum types alt arity expr)
+  = do { dsWhenNoErrs (dsLExprNoLP expr)
+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)
+                                     (map (Type . getRuntimeRep) types ++
+                                      map Type types ++
+                                      [core_expr]) ) }
 
-ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
+ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
     dflags <- getDynFlags
     if gopt Opt_SccProfilingOn dflags
       then do
         mod_name <- getModule
         count <- goptM Opt_ProfCountEntries
-        uniq <- newUnique
-        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
                <$> dsLExpr expr
       else dsLExpr expr
 
-ds_expr _ (HsCoreAnn _ _ expr)
+ds_expr _ (HsCoreAnn _ _ _ expr)
   = dsLExpr expr
 
-ds_expr _ (HsCase discrim matches)
+ds_expr _ (HsCase _ discrim matches)
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
        ; return (bindNonRec discrim_var core_discrim matching_code) }
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
-ds_expr _ (HsLet binds body) = do
+ds_expr _ (HsLet _ binds body) = do
     body' <- dsLExpr body
     dsLocalBinds binds body'
 
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
-ds_expr _ (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
-ds_expr _ (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
-ds_expr _ (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts
-
-ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ DoExpr        (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
        ; b1 <- dsLExpr then_expr
        ; b2 <- dsLExpr else_expr
@@ -445,6 +443,7 @@ ds_expr _ (HsMultiIf res_ty alts)
   | otherwise
   = do { match_result <- liftM (foldr1 combineMatchResults)
                                (mapM (dsGRHS IfAlt res_ty) alts)
+       ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))
        ; error_expr   <- mkErrorExpr
        ; extractMatchResult match_result error_expr }
   where
@@ -460,38 +459,12 @@ ds_expr _ (HsMultiIf res_ty alts)
 ds_expr _ (ExplicitList elt_ty wit xs)
   = dsExplicitList elt_ty wit xs
 
--- We desugar [:x1, ..., xn:] as
---   singletonP x1 +:+ ... +:+ singletonP xn
---
-ds_expr _ (ExplicitPArr ty []) = do
-    emptyP <- dsDPHBuiltin emptyPVar
-    return (Var emptyP `App` Type ty)
-ds_expr _ (ExplicitPArr ty xs) = do
-    singletonP <- dsDPHBuiltin singletonPVar
-    appP       <- dsDPHBuiltin appPVar
-    xs'        <- mapM dsLExprNoLP xs
-    let unary  fn x   = mkApps (Var fn) [Type ty, x]
-        binary fn x y = mkApps (Var fn) [Type ty, x, y]
-
-    return . foldr1 (binary appP) $ map (unary singletonP) xs'
-
 ds_expr _ (ArithSeq expr witness seq)
   = case witness of
      Nothing -> dsArithSeq expr seq
      Just fl -> do { newArithSeq <- dsArithSeq expr seq
                    ; dsSyntaxExpr fl [newArithSeq] }
 
-ds_expr _ (PArrSeq expr (FromTo from to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
-
-ds_expr _ (PArrSeq expr (FromThenTo from thn to))
-  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
-
-ds_expr _ (PArrSeq _ _)
-  = panic "DsExpr.dsExpr: Infinite parallel array!"
-    -- the parser shouldn't have generated it and the renamer and typechecker
-    -- shouldn't have let it through
-
 {-
 Static Pointers
 ~~~~~~~~~~~~~~~
@@ -545,8 +518,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
 constructor @C@, setting all of @C@'s fields to bottom.
 -}
 
-ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
-                     , rcon_con_like = con_like })
+ds_expr _ (RecordCon { rcon_flds = rbinds
+                     , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+                                              , rcon_con_like = con_like }})
   = do { con_expr' <- dsExpr con_expr
        ; let
              (arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -605,9 +579,11 @@ So we need to cast (T a Int) to (T a b).  Sigh.
 -}
 
 ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-                          , rupd_cons = cons_to_upd
-                          , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
-                          , rupd_wrap = dict_req_wrap } )
+                          , rupd_ext = RecordUpdTc
+                              { rupd_cons = cons_to_upd
+                              , rupd_in_tys = in_inst_tys
+                              , rupd_out_tys = out_inst_tys
+                              , rupd_wrap = dict_req_wrap }} )
   | null fields
   = dsLExpr record_expr
   | otherwise
@@ -624,11 +600,12 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
         -- constructor arguments.
         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
         ; ([discrim_var], matching_code)
-                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
-                                                   , mg_arg_tys = [in_ty]
-                                                   , mg_res_ty = out_ty, mg_origin = FromSource })
-                                                   -- FromSource is not strictly right, but we
-                                                   -- want incomplete pattern-match warnings
+                <- matchWrapper RecUpd Nothing
+                                      (MG { mg_alts = noLoc alts
+                                          , mg_ext = MatchGroupTc [in_ty] out_ty
+                                          , mg_origin = FromSource })
+                                     -- FromSource is not strictly right, but we
+                                     -- want incomplete pattern-match warnings
 
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
@@ -659,28 +636,37 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
     mk_alt upd_fld_env con
       = do { let (univ_tvs, ex_tvs, eq_spec,
                   prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
-                 subst = zipTvSubst univ_tvs in_inst_tys
+                 user_tvs =
+                   case con of
+                     RealDataCon data_con -> dataConUserTyVars data_con
+                     PatSynCon _          -> univ_tvs ++ ex_tvs
+                       -- The order here is because of the order in `TcPatSyn`.
+                 in_subst  = zipTvSubst univ_tvs in_inst_tys
+                 out_subst = zipTvSubst univ_tvs out_inst_tys
 
                 -- I'm not bothering to clone the ex_tvs
-           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
-           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
-           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
            ; let field_labels = conLikeFieldLabels con
                  val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                          field_labels arg_ids
                  mk_val_arg fl pat_arg_id
                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
 
-                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
                         -- Reconstruct with the WrapId so that unpacking happens
-                 -- The order here is because of the order in `TcPatSyn`.
                  wrap = mkWpEvVarApps theta_vars                                <.>
                         dict_req_wrap                                           <.>
-                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
-                        mkWpTyApps    [ ty
-                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
+                        mkWpTyApps    [ lookupTyVar out_subst tv
+                                          `orElse` mkTyVarTy tv
+                                      | tv <- user_tvs
                                       , not (tv `elemVarEnv` wrap_subst) ]
-                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
+                          -- Be sure to use user_tvs (which may be ordered
+                          -- differently than `univ_tvs ++ ex_tvs) above.
+                          -- See Note [DataCon user type variable binders]
+                          -- in DataCon.
+                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
 
                         -- Tediously wrap the application in a cast
                         -- Note [Update for GADTs]
@@ -723,16 +709,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
 
 -- Template Haskell stuff
 
-ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
-ds_expr _ (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
+ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
-ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
 
 -- Hpc Support
 
-ds_expr _ (HsTick tickish e) = do
+ds_expr _ (HsTick _ tickish e) = do
   e' <- dsLExpr e
   return (Tick tickish e')
 
@@ -743,20 +729,19 @@ ds_expr _ (HsTick tickish e) = do
 -- (did you go here: YES or NO), but will effect accurate
 -- tick counting.
 
-ds_expr _ (HsBinTick ixT ixF e) = do
+ds_expr _ (HsBinTick _ ixT ixF e) = do
   e2 <- dsLExpr e
   do { ASSERT(exprType e2 `eqType` boolTy)
        mkBinaryTickBox ixT ixF e2
      }
 
-ds_expr _ (HsTickPragma _ _ _ expr) = do
+ds_expr _ (HsTickPragma _ _ _ _ expr) = do
   dflags <- getDynFlags
   if gopt Opt_Hpc dflags
     then panic "dsExpr:HsTickPragma"
     else dsLExpr expr
 
 -- HsSyn constructs that just shouldn't be here:
-ds_expr _ (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
 ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
 ds_expr _ (HsArrApp      {})  = panic "dsExpr:HsArrApp"
 ds_expr _ (HsArrForm     {})  = panic "dsExpr:HsArrForm"
@@ -764,9 +749,10 @@ ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"
 ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"
 ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"
 ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat"
-ds_expr _ (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
 ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
 ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
+ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"
+
 
 ------------------------------
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
@@ -906,50 +892,50 @@ dsDo stmts
     goL [] = panic "dsDo"
     goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 
-    go _ (LastStmt body _ _) stmts
+    go _ (LastStmt _ body _ _) stmts
       = ASSERT( null stmts ) dsLExpr body
         -- The 'return' op isn't used for 'do' expressions
 
-    go _ (BodyStmt rhs then_expr _ _) stmts
+    go _ (BodyStmt _ rhs then_expr _) stmts
       = do { rhs2 <- dsLExpr rhs
            ; warnDiscardedDoBindings rhs (exprType rhs2)
            ; rest <- goL stmts
            ; dsSyntaxExpr then_expr [rhs2, rest] }
 
-    go _ (LetStmt binds) stmts
+    go _ (LetStmt _ binds) stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
-    go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
+    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL pat
-            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+            ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
                                       res1_ty (cantFailMatchResult body)
             ; match_code <- handle_failure pat match fail_op
             ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
-    go _ (ApplicativeStmt args mb_join body_ty) stmts
+    go _ (ApplicativeStmt body_ty args mb_join) stmts
       = do {
              let
                (pats, rhss) = unzip (map (do_arg . snd) args)
 
-               do_arg (ApplicativeArgOne pat expr) =
+               do_arg (ApplicativeArgOne _ pat expr _) =
                  (pat, dsLExpr expr)
-               do_arg (ApplicativeArgMany stmts ret pat) =
+               do_arg (ApplicativeArgMany _ stmts ret pat) =
                  (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+               do_arg (XApplicativeArg _) = panic "dsDo"
 
                arg_tys = map hsLPatType pats
 
            ; rhss' <- sequence rhss
 
-           ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
+           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
 
-           ; let fun = L noSrcSpan $ HsLam $
+           ; let fun = L noSrcSpan $ HsLam noExt $
                    MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
                                                        body']
-                      , mg_arg_tys = arg_tys
-                      , mg_res_ty = body_ty
+                      , mg_ext = MatchGroupTc arg_tys body_ty
                       , mg_origin = Generated }
 
            ; fun' <- dsLExpr fun
@@ -962,14 +948,15 @@ dsDo stmts
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_bind_ty = bind_ty
-                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
+                    , recS_ext = RecStmtTc
+                        { recS_bind_ty = bind_ty
+                        , recS_rec_rets = rec_rets
+                        , recS_ret_ty = body_ty} }) stmts
       = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
       where
-        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
+        new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
                                          mfix_app bind_op
                                          noSyntaxExpr  -- Tuple cannot fail
-                                         bind_ty
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
@@ -977,15 +964,15 @@ dsDo stmts
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
         mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
-        mfix_arg     = noLoc $ HsLam
+        mfix_arg     = noLoc $ HsLam noExt
                            (MG { mg_alts = noLoc [mkSimpleMatch
                                                     LambdaExpr
                                                     [mfix_pat] body]
-                               , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
+                               , mg_ext = MatchGroupTc [tup_ty] body_ty
                                , mg_origin = Generated })
-        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
-        body         = noLoc $ HsDo
-                                DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
+        mfix_pat     = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
         ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
         ret_stmt     = noLoc $ mkLastStmt ret_app
                      -- This LastStmt will be desugared with dsDo,
@@ -994,6 +981,7 @@ dsDo stmts
 
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
+    go _ (XStmtLR   {}) _ = panic "dsDo XStmtLR"
 
 handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
@@ -1147,9 +1135,9 @@ we're not directly in an HsWrap, reject.
 checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
 checkForcedEtaExpansion expr ty
   | Just var <- case expr of
-                  HsVar (L _ var)               -> Just var
-                  HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc)
-                  _                             -> Nothing
+                  HsVar _ (L _ var)               -> Just var
+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+                  _                               -> Nothing
   , let bad_tys = badUseOfLevPolyPrimop var ty
   , not (null bad_tys)
   = levPolyPrimopErr var ty bad_tys
@@ -1172,6 +1160,6 @@ badUseOfLevPolyPrimop id ty
 levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
 levPolyPrimopErr primop ty bad_tys
   = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
-                      2 (ppr primop <+> dcolon <+> ppr ty)
+                      2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
                  , hang (text "Levity-polymorphic arguments:")
-                      2 (vcat (map (\t -> ppr t <+> dcolon <+> ppr (typeKind t)) bad_tys)) ]
+                      2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index 9b088b280d..5856ff2445 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -13,6 +13,8 @@ Desugaring foreign declarations (see also DsCCall).
 module DsForeign ( dsForeigns ) where
 
 #include "HsVersions.h"
+import GhcPrelude
+
 import TcRnMonad        -- temp
 
 import CoreSyn
@@ -97,17 +99,18 @@ dsForeigns' fos = do
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
 
-   do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
+   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
       traceIf (text "fi start" <+> ppr id)
       let id' = unLoc id
       (bs, h, c) <- dsFImport id' co spec
       traceIf (text "fi end" <+> ppr id)
       return (h, c, [], bs)
 
-   do_decl (ForeignExport { fd_name = L _ id, fd_co = co
+   do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co
                           , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
       (h, c, _, _) <- dsFExport id co ext_nm cconv False
       return (h, c, [id], [])
+   do_decl (XForeignDecl _) = panic "dsForeigns'"
 
 {-
 ************************************************************************
@@ -200,7 +203,7 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
 dsFCall fn_id co fcall mDeclHeader = do
     let
         ty                   = pFst $ coercionKind co
-        (tv_bndrs, rho)      = tcSplitForAllTyVarBndrs ty
+        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
         (arg_tys, io_res_ty) = tcSplitFunTys rho
 
     args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
@@ -227,7 +230,8 @@ dsFCall fn_id co fcall mDeclHeader = do
                                       CApiConv safety)
                       c = includes
                        $$ fun_proto <+> braces (cRet <> semi)
-                      includes = vcat [ text "#include <" <> ftext h <> text ">"
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
                                       | Header _ h <- nub headers ]
                       fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
                       cRet
@@ -601,7 +605,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   -- the expression we give to rts_evalIO
   expr_to_run
-     = foldl appArg the_cfun arg_info -- NOT aug_arg_info
+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
        where
           appArg acc (arg_cname, _, arg_hty, _)
              = text "rts_apply"
@@ -715,6 +719,12 @@ toCType = f False
            -- through one layer of type synonym etc.
            | Just t' <- coreView t
               = f voidOK t'
+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
+           -- (which is marshalled like a Ptr)
+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
+              = (Nothing, text "void*")
            -- Otherwise we don't know the C type. If we are allowing
            -- void then return that; otherwise something has gone wrong.
            | voidOK = (Nothing, text "void")
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index c3dcdf6879..00658539d3 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -12,26 +12,27 @@ module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
-import {-# SOURCE #-} Match   ( matchSinglePat )
+import {-# SOURCE #-} Match   ( matchSinglePatVar )
 
 import HsSyn
 import MkCore
 import CoreSyn
+import CoreUtils (bindNonRec)
 
+import Check (genCaseTmCs2)
 import DsMonad
 import DsUtils
-import TysWiredIn
-import PrelNames
 import Type   ( Type )
-import Module
 import Name
 import Util
 import SrcLoc
 import Outputable
 
 {-
-@dsGuarded@ is used for both @case@ expressions and pattern bindings.
+@dsGuarded@ is used for pattern bindings.
 It desugars:
 \begin{verbatim}
         | g1 -> e1
@@ -44,7 +45,6 @@ necessary.  The type argument gives the type of the @ei@.
 -}
 
 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
-
 dsGuarded grhss rhs_ty = do
     match_result <- dsGRHSs PatBindRhs grhss rhs_ty
     error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
@@ -56,18 +56,20 @@ dsGRHSs :: HsMatchContext Name
         -> GRHSs GhcTc (LHsExpr GhcTc)          -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
-dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty
+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
   = ASSERT( notNull grhss )
     do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
        ; let match_result1 = foldr1 combineMatchResults match_results
              match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
                              -- NB: nested dsLet inside matchResult
        ; return match_result2 }
+dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
 
 dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
        -> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
+dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS"
 
 {-
 ************************************************************************
@@ -97,16 +99,16 @@ matchGuards [] _ rhs _
         -- NB:  The success of this clause depends on the typechecker not
         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
         --      If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
   | Just addTicks <- isTrueLHsExpr e = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     pred_expr <- dsLExpr expr
     return (mkGuardedMatchResult pred_expr match_result)
 
-matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     return (adjustMatchResultDs (dsLocalBinds binds) match_result)
         -- NB the dsLet occurs inside the match_result
@@ -114,10 +116,19 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
         --         so we can't desugar the bindings without the
         --         body expression in hand
 
-matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx rhs rhs_ty
+matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
+    match_result <- addDictsDs dicts $
+                    addTmCsDs tm_cs  $
+                      -- See Note [Type and Term Equality Propagation] in Check
+                    matchGuards stmts ctx rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
-    matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
 
 matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
 matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
@@ -125,34 +136,8 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
 matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"
 matchGuards (ApplicativeStmt {} : _) _ _ _ =
   panic "matchGuards ApplicativeLastStmt"
-
-isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-
--- Returns Just {..} if we're sure that the expression is True
--- I.e.   * 'True' datacon
---        * 'otherwise' Id
---        * Trivial wappings of these
--- The arguments to Just are any HsTicks that we have found,
--- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey
-                                    || v `hasKey` getUnique trueDataConId
-                                            = Just return
-        -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick tickish e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do wrapped <- ticks x
-                     return (Tick tickish wrapped))
-   -- This encodes that the result is constant True for Hpc tick purposes;
-   -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick ixT _ e))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do e <- ticks x
-                     this_mod <- getModule
-                     return (Tick (HpcTick this_mod ixT) e))
-
-isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
-isTrueLHsExpr _                       = Nothing
+matchGuards (XStmtLR {} : _) _ _ _ =
+  panic "matchGuards XStmtLR"
 
 {-
 Should {\em fail} if @e@ returns @D@
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index dc24183537..f325b5672d 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -9,10 +9,12 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
 {-# LANGUAGE CPP, NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
+module DsListComp ( dsListComp, dsMonadComp ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
 
 import HsSyn
@@ -80,7 +82,7 @@ dsListComp lquals res_ty = do
 -- of that comprehension that we need in the outer comprehension into such an expression
 -- and the type of the elements that it outputs (tuples of binders)
 dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock stmts bndrs _)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
   = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
              list_ty          = mkListTy bndrs_tuple_type
 
@@ -88,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
        ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
 
        ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
 
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -103,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
         to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
 
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+                                                        from_bndrs noSyntaxExpr)
 
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
@@ -204,7 +208,7 @@ where (x1, .., xn) are the variables bound in p1, v1, p2
 In the translation below, the ParStmt branch translates each parallel branch
 into a sub-comprehension, and desugars each independently.  The resulting lists
 are fed to a zip function, we create a binding for all the variables bound in all
-the comprehensions, and then we hand things off the the desugarer for bindings.
+the comprehensions, and then we hand things off the desugarer for bindings.
 The zip function is generated here a) because it's small, and b) because then we
 don't have to deal with arbitrary limits on the number of zip functions in the
 prelude, nor which library the zip function came from.
@@ -216,20 +220,20 @@ deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
 
 deListComp [] _ = panic "deListComp"
 
-deListComp (LastStmt body _ _ : quals) list
+deListComp (LastStmt _ body _ _ : quals) list
   =     -- Figure 7.4, SLPJ, p 135, rule C above
     ASSERT( null quals )
     do { core_body <- dsLExpr body
        ; return (mkConsExpr (exprType core_body) core_body list) }
 
         -- Non-last: must be a guard
-deListComp (BodyStmt guard _ _ _ : quals) list = do  -- rule B above
+deListComp (BodyStmt _ guard _ _ : quals) list = do  -- rule B above
     core_guard <- dsLExpr guard
     core_rest <- deListComp quals list
     return (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) list = do
+deListComp (LetStmt _ binds : quals) list = do
     core_rest <- deListComp quals list
     dsLocalBinds binds core_rest
 
@@ -237,11 +241,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
     (inner_list_expr, pat) <- dsTransStmt stmt
     deBindComp pat inner_list_expr quals list
 
-deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above
+deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
     core_list1 <- dsLExprNoLP list1
     deBindComp pat core_list1 quals core_list2
 
-deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
   = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
        ; let (exps, qual_tys) = unzip exps_and_qual_tys
 
@@ -251,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
        ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
                     quals list }
   where
-        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
 
         -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
         pat  = mkBigLHsPatTupId pats
@@ -262,6 +266,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
 deListComp (ApplicativeStmt {} : _) _ =
   panic "deListComp ApplicativeStmt"
 
+deListComp (XStmtLR {} : _) _ =
+  panic "deListComp XStmtLR"
+
 deBindComp :: OutPat GhcTc
            -> CoreExpr
            -> [ExprStmt GhcTc]
@@ -324,18 +331,18 @@ dfListComp :: Id -> Id            -- 'c' and 'n'
 
 dfListComp _ _ [] = panic "dfListComp"
 
-dfListComp c_id n_id (LastStmt body _ _ : quals)
+dfListComp c_id n_id (LastStmt _ body _ _ : quals)
   = ASSERT( null quals )
     do { core_body <- dsLExprNoLP body
        ; return (mkApps (Var c_id) [core_body, Var n_id]) }
 
         -- Non-last: must be a guard
-dfListComp c_id n_id (BodyStmt guard _ _ _  : quals) = do
+dfListComp c_id n_id (BodyStmt _ guard _ _  : quals) = do
     core_guard <- dsLExpr guard
     core_rest <- dfListComp c_id n_id quals
     return (mkIfThenElse core_guard core_rest (Var n_id))
 
-dfListComp c_id n_id (LetStmt binds : quals) = do
+dfListComp c_id n_id (LetStmt _ binds : quals) = do
     -- new in 1.3, local bindings
     core_rest <- dfListComp c_id n_id quals
     dsLocalBinds binds core_rest
@@ -345,7 +352,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
     -- Anyway, we bind the newly grouped list via the generic binding function
     dfBindComp c_id n_id (pat, inner_list_expr) quals
 
-dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do
+dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
     -- evaluate the two lists
     core_list1 <- dsLExpr list1
 
@@ -356,6 +363,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
 dfListComp _ _ (ApplicativeStmt {} : _) =
   panic "dfListComp ApplicativeStmt"
+dfListComp _ _ (XStmtLR {} : _) =
+  panic "dfListComp XStmtLR"
 
 dfBindComp :: Id -> Id             -- 'c' and 'n'
            -> (LPat GhcTc, CoreExpr)
@@ -467,209 +476,6 @@ mkUnzipBind _ elt_tys
 
     mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
 
-{-
-************************************************************************
-*                                                                      *
-\subsection[DsPArrComp]{Desugaring of array comprehensions}
-*                                                                      *
-************************************************************************
--}
-
--- entry point for desugaring a parallel array comprehension
---
---   [:e | qss:] = <<[:e | qss:]>> () [:():]
---
-dsPArrComp :: [ExprStmt GhcTc]
-            -> DsM CoreExpr
-
--- Special case for parallel comprehension
-dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-
--- Special case for simple generators:
---
---  <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
---
--- if matching again p cannot fail, or else
---
---  <<[:e' | p <- e, qs:]>> =
---    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
---
-dsPArrComp (BindStmt p e _ _ _ : qs) = do
-    filterP <- dsDPHBuiltin filterPVar
-    ce <- dsLExprNoLP e
-    let ety'ce  = parrElemType ce
-        false   = Var falseDataConId
-        true    = Var trueDataConId
-    v <- newSysLocalDs ety'ce
-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
-    let gen | isIrrefutableHsPat p = ce
-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
-    dePArrComp qs p gen
-
-dsPArrComp qs = do -- no ParStmt in `qs'
-    sglP <- dsDPHBuiltin singletonPVar
-    let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
-    dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-
-
-
--- the work horse
---
-dePArrComp :: [ExprStmt GhcTc]
-           -> LPat GhcTc        -- the current generator pattern
-           -> CoreExpr          -- the current generator expression
-           -> DsM CoreExpr
-
-dePArrComp [] _ _ = panic "dePArrComp"
-
---
---  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
---
-dePArrComp (LastStmt e' _ _ : quals) pa cea
-  = ASSERT( null quals )
-    do { mapP <- dsDPHBuiltin mapPVar
-       ; let ty = parrElemType cea
-       ; (clam, ty'e') <- deLambda ty pa e'
-       ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
---
---  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
---
-dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
-    filterP <- dsDPHBuiltin filterPVar
-    let ty = parrElemType cea
-    (clam,_) <- deLambda ty pa b
-    dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
-
---
---  <<[:e' | p <- e, qs:]>> pa ea =
---    let ef = \pa -> e
---    in
---    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
---
--- if matching again p cannot fail, or else
---
---  <<[:e' | p <- e, qs:]>> pa ea =
---    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
---    in
---    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
---
-dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
-    filterP <- dsDPHBuiltin filterPVar
-    crossMapP <- dsDPHBuiltin crossMapPVar
-    ce <- dsLExpr e
-    let ety'cea = parrElemType cea
-        ety'ce  = parrElemType ce
-        false   = Var falseDataConId
-        true    = Var trueDataConId
-    v <- newSysLocalDs ety'ce
-    pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
-    let cef | isIrrefutableHsPat p = ce
-            | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
-    (clam, _) <- mkLambda ety'cea pa cef
-    let ety'cef = ety'ce                    -- filter doesn't change the element type
-        pa'     = mkLHsPatTup [pa, p]
-
-    dePArrComp qs pa' (mkApps (Var crossMapP)
-                                 [Type ety'cea, Type ety'cef, cea, clam])
---
---  <<[:e' | let ds, qs:]>> pa ea =
---    <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
---                    (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)
---  where
---    {x_1, ..., x_n} = DV (ds)         -- Defined Variables
---
-dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do
-    mapP <- dsDPHBuiltin mapPVar
-    let xs = collectLocalBinders ds
-        ty'cea = parrElemType cea
-    v <- newSysLocalDs ty'cea
-    clet <- dsLocalBinds lds (mkCoreTup (map Var xs))
-    let'v <- newSysLocalDs (exprType clet)
-    let projBody = mkCoreLet (NonRec let'v clet) $
-                   mkCoreTup [Var v, Var let'v]
-        errTy    = exprType projBody
-        errMsg   = text "DsListComp.dePArrComp: internal error!"
-    cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg
-    ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
-    let pa'    = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
-        proj   = mkLams [v] ccase
-    dePArrComp qs pa' (mkApps (Var mapP)
-                                   [Type ty'cea, Type errTy, proj, cea])
---
--- The parser guarantees that parallel comprehensions can only appear as
--- singleton qualifier lists, which we already special case in the caller.
--- So, encountering one here is a bug.
---
-dePArrComp (ParStmt {} : _) _ _ =
-  panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
-dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
-dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
-dePArrComp (ApplicativeStmt   {} : _) _ _ =
-  panic "DsListComp.dePArrComp: ApplicativeStmt"
-
---  <<[:e' | qs | qss:]>> pa ea =
---    <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
---                     (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
---    where
---      {x_1, ..., x_n} = DV (qs)
---
-dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr
-dePArrParComp qss quals = do
-    (pQss, ceQss) <- deParStmt qss
-    dePArrComp quals pQss ceQss
-  where
-    deParStmt []             =
-      -- empty parallel statement lists have no source representation
-      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
-    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
-      let res_expr = mkLHsVarTuple xs
-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
-      parStmts qss (mkLHsVarPatTup xs) cqs
-    ---
-    parStmts []             pa cea = return (pa, cea)
-    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)
-      zipP <- dsDPHBuiltin zipPVar
-      let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
-          ty'cea   = parrElemType cea
-          res_expr = mkLHsVarTuple xs
-      cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
-      let ty'cqs = parrElemType cqs
-          cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
-      parStmts qss pa' cea'
-
--- generate Core corresponding to `\p -> e'
---
-deLambda :: Type                       -- type of the argument (not levity-polymorphic)
-         -> LPat GhcTc                 -- argument pattern
-         -> LHsExpr GhcTc              -- body
-         -> DsM (CoreExpr, Type)
-deLambda ty p e =
-    mkLambda ty p =<< dsLExpr e
-
--- generate Core for a lambda pattern match, where the body is already in Core
---
-mkLambda :: Type                        -- type of the argument (not levity-polymorphic)
-         -> LPat GhcTc                  -- argument pattern
-         -> CoreExpr                    -- desugared body
-         -> DsM (CoreExpr, Type)
-mkLambda ty p ce = do
-    v <- newSysLocalDs ty
-    let errMsg = text "DsListComp.deLambda: internal error!"
-        ce'ty  = exprType ce
-    cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg
-    res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr
-    return (mkLams [v] res, ce'ty)
-
--- obtain the element type of the parallel array produced by the given Core
--- expression
---
-parrElemType   :: CoreExpr -> Type
-parrElemType e  =
-  case splitTyConApp_maybe (exprType e) of
-    Just (tycon, [ty]) | tycon == parrTyCon -> ty
-    _                                                     -> panic
-      "DsListComp.parrElemType: not a parallel array type"
-
 -- Translation for monad comprehensions
 
 -- Entry point for monad comprehension desugaring
@@ -683,18 +489,18 @@ dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
 ---------------
 dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
 
-dsMcStmt (LastStmt body _ ret_op) stmts
+dsMcStmt (LastStmt _ body _ ret_op) stmts
   = ASSERT( null stmts )
     do { body' <- dsLExpr body
        ; dsSyntaxExpr ret_op [body'] }
 
 --   [ .. | let binds, stmts ]
-dsMcStmt (LetStmt binds) stmts
+dsMcStmt (LetStmt _ binds) stmts
   = do { rest <- dsMcStmts stmts
        ; dsLocalBinds binds rest }
 
 --   [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
   = do { rhs' <- dsLExpr rhs
        ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
 
@@ -702,7 +508,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
 --
 --   [ .. | exp, stmts ]
 --
-dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
   = do { exp'       <- dsLExpr exp
        ; rest       <- dsMcStmts stmts
        ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
@@ -725,7 +531,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
 dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
                     , trS_by = by, trS_using = using
                     , trS_ret = return_op, trS_bind = bind_op
-                    , trS_bind_arg_ty = n_tup_ty'  -- n (a,b,c)
+                    , trS_ext = n_tup_ty'  -- n (a,b,c)
                     , trS_fmap = fmap_op, trS_form = form }) stmts_rest
   = do { let (from_bndrs, to_bndrs) = unzip bndrs
 
@@ -770,12 +576,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
 --   mzip :: forall a b. m a -> m b -> m (a,b)
 -- NB: we need a polymorphic mzip because we call it several times
 
-dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
+dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
  = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
        ; mzip_op'    <- dsExpr mzip_op
 
        ; let -- The pattern variables
-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
              -- Pattern with tuples of variables
              -- [v1,v2,v3]  =>  (v1, (v2, v3))
              pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -786,9 +592,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
 
        ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
   where
-    ds_inner (ParStmtBlock stmts bndrs return_op)
+    ds_inner (ParStmtBlock _ stmts bndrs return_op)
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
             ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
 
 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 
@@ -814,7 +621,7 @@ dsMcBindStmt :: LPat GhcTc
 dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
   = do  { body     <- dsMcStmts stmts
         ; var      <- selectSimpleMatchVarL pat
-        ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
                                   res1_ty (cantFailMatchResult body)
         ; match_code <- handle_failure pat match fail_op
         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
@@ -846,7 +653,8 @@ dsInnerMonadComp :: [ExprLStmt GhcTc]
                  -> SyntaxExpr GhcTc   -- The monomorphic "return" operator
                  -> DsM CoreExpr
 dsInnerMonadComp stmts bndrs ret_op
-  = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
+  = dsMcStmts (stmts ++
+                 [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])
 
 
 -- The `unzip` function for `GroupStmt` in a monad comprehensions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index c6799813df..d25a7cfd06 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -20,6 +20,8 @@ module DsMeta( dsBracket ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   DsExpr ( dsExpr )
 
 import MatchLit
@@ -28,7 +30,6 @@ import DsMonad
 import qualified Language.Haskell.TH as TH
 
 import HsSyn
-import Class
 import PrelNames
 -- To avoid clashes with DsMeta.varName we must make a local alias for
 -- OccName.varName we do this by removing varName from the import of
@@ -75,13 +76,14 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
 
-    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
-    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
 
 {- -------------- Examples --------------------
 
@@ -118,9 +120,8 @@ repTopDs group@(HsGroup { hs_valds   = valds
                         , hs_warnds  = warnds
                         , hs_annds   = annds
                         , hs_ruleds  = ruleds
-                        , hs_vects   = vects
                         , hs_docs    = docs })
- = do { let { bndrs  = hsSigTvBinders valds
+ = do { let { bndrs  = hsScopedTvBinders valds
                        ++ hsGroupBinders group
                        ++ hsPatSynSelectors valds
             ; instds = tyclds >>= group_instds } ;
@@ -148,7 +149,6 @@ repTopDs group@(HsGroup { hs_valds   = valds
                      ; ann_ds   <- mapM repAnnD annds
                      ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                             ruleds)
-                     ; _        <- mapM no_vect vects
                      ; _        <- mapM no_doc docs
 
                         -- more needed
@@ -171,33 +171,44 @@ repTopDs group@(HsGroup { hs_valds   = valds
       = notHandledL loc "Splices within declaration brackets" empty
     no_default_decl (L loc decl)
       = notHandledL loc "Default declarations" (ppr decl)
-    no_warn (L loc (Warning thing _))
+    no_warn (L loc (Warning _ thing _))
       = notHandledL loc "WARNING and DEPRECATION pragmas" $
                     text "Pragma for declaration of" <+> ppr thing
-    no_vect (L loc decl)
-      = notHandledL loc "Vectorisation pragmas" (ppr decl)
+    no_warn (L _ (XWarnDecl _)) = panic "repTopDs"
     no_doc (L loc _)
       = notHandledL loc "Haddock documentation" empty
+repTopDs (XHsGroup _) = panic "repTopDs"
 
-hsSigTvBinders :: HsValBinds GhcRn -> [Name]
+hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
 -- See Note [Scoped type variables in bindings]
-hsSigTvBinders binds
+hsScopedTvBinders binds
   = concatMap get_scoped_tvs sigs
   where
-    get_scoped_tvs :: LSig GhcRn -> [Name]
-    -- Both implicit and explicit quantified variables
-    -- We need the implicit ones for   f :: forall (a::k). blah
-    --    here 'k' scopes too
-    get_scoped_tvs (L _ (TypeSig _ sig))
-       | HsIB { hsib_vars = implicit_vars
-              , hsib_body = hs_ty } <- hswc_body sig
-       , (explicit_vars, _) <- splitLHsForAllTy hs_ty
-       = implicit_vars ++ map hsLTyVarName explicit_vars
-    get_scoped_tvs _ = []
-
     sigs = case binds of
-             ValBindsIn  _ sigs -> sigs
-             ValBindsOut _ sigs -> sigs
+             ValBinds           _ _ sigs  -> sigs
+             XValBindsLR (NValBinds _ sigs) -> sigs
+
+get_scoped_tvs :: LSig GhcRn -> [Name]
+get_scoped_tvs (L _ signature)
+  | TypeSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig (hswc_body sig)
+  | ClassOpSig _ _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | PatSynSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | otherwise
+  = []
+  where
+    get_scoped_tvs_from_sig sig
+      -- Both implicit and explicit quantified variables
+      -- We need the implicit ones for   f :: forall (a::k). blah
+      --    here 'k' scopes too
+      | HsIB { hsib_ext = implicit_vars
+             , hsib_body = hs_ty } <- sig
+      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
+      = implicit_vars ++ map hsLTyVarName explicit_vars
+    get_scoped_tvs_from_sig (XHsImplicitBndrs _)
+      = panic "get_scoped_tvs_from_sig"
 
 {- Notes
 
@@ -210,12 +221,37 @@ Here the 'forall a' brings 'a' into scope over the binding group.
 To achieve this we
 
   a) Gensym a binding for 'a' at the same time as we do one for 'f'
-     collecting the relevant binders with hsSigTvBinders
+     collecting the relevant binders with hsScopedTvBinders
 
   b) When processing the 'forall', don't gensym
 
 The relevant places are signposted with references to this Note
 
+Note [Scoped type variables in class and instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Scoped type variables may occur in default methods and default
+signatures. We need to bring the type variables in 'foralls'
+into the scope of the method bindings.
+
+Consider
+   class Foo a where
+     foo :: forall (b :: k). a -> Proxy b -> Proxy b
+     foo _ x = (x :: Proxy b)
+
+We want to ensure that the 'b' in the type signature and the default
+implementation are the same, so we do the following:
+
+  a) Before desugaring the signature and binding of 'foo', use
+     get_scoped_tvs to collect type variables in 'forall' and
+     create symbols for them.
+  b) Use 'addBinds' to bring these symbols into the scope of the type
+     signatures and bindings.
+  c) Use these symbols to generate Core for the class/instance declaration.
+
+Note that when desugaring the signatures, we lookup the type variables
+from the scope rather than recreate symbols for them. See more details
+in "rep_ty_sig" and in Trac#14885.
+
 Note [Binders and occurrences]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we desugar [d| data T = MkT |]
@@ -251,10 +287,8 @@ and have Template Haskell turn it into this:
   idProxy :: forall k proxy (b :: k). proxy b -> proxy b
   idProxy x = x
 
-Notice that we explicitly quantified the variable `k`! This is quite bad, as the
-latter declaration requires -XTypeInType, while the former does not. Not to
-mention that the latter declaration isn't even what the user wrote in the
-first place.
+Notice that we explicitly quantified the variable `k`! The latter declaration
+isn't what the user wrote in the first place.
 
 Usually, the culprit behind these bugs is taking implicitly quantified type
 variables (often from the hsib_vars field of HsImplicitBinders) and putting
@@ -286,28 +320,31 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
   = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
        ; dec  <- addTyVarBinds tvs $ \bndrs ->
            do { cxt1   <- repLContext cxt
-              ; sigs1  <- rep_sigs sigs
-              ; binds1 <- rep_binds meth_binds
+              -- See Note [Scoped type variables in class and instance declarations]
+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
               ; fds1   <- repLFunDeps fds
               ; ats1   <- repFamilyDecls ats
               ; atds1  <- repAssocTyFamDefaults atds
-              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)
-              ; repClass cxt1 cls1 bndrs fds1 decls1
-              }
+              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
+              ; wrapGenSyms ss decls2 }
        ; return $ Just (loc, dec)
        }
 
+repTyClD (L _ (XTyClDecl _)) = panic "repTyClD"
+
 -------------------------
 repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRoleD (L loc (RoleAnnotDecl tycon roles))
+repRoleD (L loc (RoleAnnotDecl _ tycon roles))
   = do { tycon1 <- lookupLOcc tycon
        ; roles1 <- mapM repRole roles
        ; roles2 <- coreList roleTyConName roles1
        ; dec <- repRoleAnnotD tycon1 roles2
        ; return (loc, dec) }
+repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
 
 -------------------------
-repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
             -> Maybe (Core [TH.TypeQ])
             -> HsDataDefn GhcRn
             -> DsM (Core TH.DecQ)
@@ -318,20 +355,21 @@ repDataDefn tc bndrs opt_tys
        ; derivs1  <- repDerivs mb_derivs
        ; case (new_or_data, cons) of
            (NewType, [con])  -> do { con'  <- repC con
-                                   ; ksig' <- repMaybeLKind ksig
+                                   ; ksig' <- repMaybeLTy ksig
                                    ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                 derivs1 }
            (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                        <+> pprQuotedList
                                        (getConNames $ unLoc $ head cons))
-           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
                                ; consL <- mapM repC cons
                                ; cons1 <- coreList conQTyConName consL
                                ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                          derivs1 }
        }
+repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn"
 
-repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
            -> LHsType GhcRn
            -> DsM (Core TH.DecQ)
 repSynDecl tc bndrs ty
@@ -346,18 +384,20 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                                         fdInjectivityAnn = injectivity }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
        ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
-             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
-                                   , hsq_dependent = emptyNameSet }
+             mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
+                                                { hsq_implicit = []
+                                                , hsq_dependent = emptyNameSet }
+                                   , hsq_explicit = tvs }
              resTyVar = case resultSig of
-                     TyVarSig bndr -> mkHsQTvs [bndr]
-                     _             -> mkHsQTvs []
+                     TyVarSig _ bndr -> mkHsQTvs [bndr]
+                     _               -> mkHsQTvs []
        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                 addTyClTyVarBinds resTyVar $ \_ ->
            case info of
              ClosedTypeFamily Nothing ->
                  notHandled "abstract closed type family" (ppr decl)
              ClosedTypeFamily (Just eqns) ->
-               do { eqns1  <- mapM repTyFamEqn eqns
+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
                   ; eqns2  <- coreList tySynEqnQTyConName eqns1
                   ; result <- repFamilyResultSig resultSig
                   ; inj    <- repInjectivityAnn injectivity
@@ -371,25 +411,27 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                   ; repDataFamilyD tc1 bndrs kind }
        ; return (loc, dec)
        }
+repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl"
 
 -- | Represent result signature of a type family
-repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSig)
-repFamilyResultSig  NoSig          = repNoSig
-repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki
-                                        ; repKindSig ki' }
-repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
-                                        ; repTyVarSig bndr' }
+repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
+repFamilyResultSig (NoSig _)         = repNoSig
+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
+                                          ; repKindSig ki' }
+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
+                                          ; repTyVarSig bndr' }
+repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
 
 -- | Represent result signature using a Maybe Kind. Used with data families,
 -- where the result signature can be either missing or a kind but never a named
 -- result variable.
 repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
-                              -> DsM (Core (Maybe TH.Kind))
-repFamilyResultSigToMaybeKind NoSig =
-    do { coreNothing kindTyConName }
-repFamilyResultSigToMaybeKind (KindSig ki) =
-    do { ki' <- repLKind ki
-       ; coreJust kindTyConName ki' }
+                              -> DsM (Core (Maybe TH.KindQ))
+repFamilyResultSigToMaybeKind (NoSig _) =
+    do { coreNothing kindQTyConName }
+repFamilyResultSigToMaybeKind (KindSig _ ki) =
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
 repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
 
 -- | Represent injectivity annotation of a type family
@@ -412,9 +454,9 @@ repAssocTyFamDefaults = mapM rep_deflt
   where
      -- very like repTyFamEqn, but different in the details
     rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
-    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
-                             , tfe_pats  = bndrs
-                             , tfe_rhs   = rhs }))
+    rep_deflt (L _ (FamEqn { feqn_tycon = tc
+                           , feqn_pats  = bndrs
+                           , feqn_rhs   = rhs }))
       = addTyClTyVarBinds bndrs $ \ _ ->
         do { tc1  <- lookupLOcc tc
            ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
@@ -422,14 +464,15 @@ repAssocTyFamDefaults = mapM rep_deflt
            ; rhs1 <- repLTy rhs
            ; eqn1 <- repTySynEqn tys2 rhs1
            ; repTySynInst tc1 eqn1 }
+    rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
 
 -------------------------
 -- represent fundeps
 --
-repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
+repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
 repLFunDeps fds = repList funDepTyConName repLFunDep fds
 
-repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
+repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
 repLFunDep (L _ (xs, ys))
    = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
         ys' <- repList nameTyConName (lookupBinder . unLoc) ys
@@ -447,10 +490,11 @@ repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
   = do { dec <- repClsInstD cls_decl
        ; return (loc, dec) }
+repInstD (L _ (XInstDecl _)) = panic "repInstD"
 
 repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-                         , cid_sigs = prags, cid_tyfam_insts = ats
+                         , cid_sigs = sigs, cid_tyfam_insts = ats
                          , cid_datafam_insts = adts
                          , cid_overlap_mode = overlap
                          })
@@ -464,17 +508,19 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
             -- For example, the method names should be bound to
             -- the selector Ids, not to fresh names (Trac #5410)
             --
-            do { cxt1 <- repLContext cxt
+            do { cxt1     <- repLContext cxt
                ; inst_ty1 <- repLTy inst_ty
-               ; binds1 <- rep_binds binds
-               ; prags1 <- rep_sigs prags
-               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
-               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
-               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
-               ; rOver <- repOverlap (fmap unLoc overlap)
-               ; repInst rOver cxt1 inst_ty1 decls }
+               -- See Note [Scoped type variables in class and instance declarations]
+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
+               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
+               ; rOver  <- repOverlap (fmap unLoc overlap)
+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+               ; wrapGenSyms ss decls2 }
  where
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+repClsInstD (XClsInstDecl _) = panic "repClsInstD"
 
 repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
@@ -486,7 +532,8 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                    ; repDeriv strat' cxt' inst_ty' }
        ; return (loc, dec) }
   where
-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD"
 
 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
@@ -495,30 +542,40 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
        ; eqn1 <- repTyFamEqn eqn
        ; repTySynInst tc eqn1 }
 
-repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
-repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
-                                             , hsib_vars = var_names }
-                           , tfe_rhs = rhs }))
-  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
-                             , hsq_explicit = []
-                             , hsq_dependent = emptyNameSet }   -- Yuk
+repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (HsIB { hsib_ext = var_names
+                  , hsib_body = FamEqn { feqn_pats = tys
+                                       , feqn_rhs  = rhs }})
+  = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+                               { hsq_implicit = var_names
+                               , hsq_dependent = emptyNameSet }   -- Yuk
+                             , hsq_explicit = [] }
        ; addTyClTyVarBinds hs_tvs $ \ _ ->
          do { tys1 <- repLTys tys
             ; tys2 <- coreList typeQTyConName tys1
             ; rhs1 <- repLTy rhs
             ; repTySynEqn tys2 rhs1 } }
+repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
+repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
 
 repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
-repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
-                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
-                                 , dfid_defn = defn })
+repDataFamInstD (DataFamInstDecl { dfid_eqn =
+                  (HsIB { hsib_ext = var_names
+                        , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_pats  = tys
+                                             , feqn_rhs   = defn }})})
   = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
-       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
-                             , hsq_explicit = []
-                             , hsq_dependent = emptyNameSet }   -- Yuk
+       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+                                 { hsq_implicit = var_names
+                                 , hsq_dependent = emptyNameSet }   -- Yuk
+                             , hsq_explicit = [] }
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repList typeQTyConName repLTy tys
             ; repDataDefn tc bndrs (Just tys1) defn } }
+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "repDataFamInstD"
+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "repDataFamInstD"
 
 repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
 repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
@@ -562,7 +619,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
 repSafety PlaySafe = rep2 safeName []
 
 repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-repFixD (L loc (FixitySig names (Fixity _ prec dir)))
+repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
   = do { MkC prec' <- coreIntLit prec
        ; let rep_fn = case dir of
                         InfixL -> infixLDName
@@ -573,9 +630,10 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
                    ; dec <- rep2 rep_fn [prec', name']
                    ; return (loc,dec) }
        ; mapM do_one names }
+repFixD (L _ (XFixitySig _)) = panic "repFixD"
 
 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
+repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
   = do { let bndr_names = concatMap ruleBndrNames bndrs
        ; ss <- mkGenSyms bndr_names
        ; rule1 <- addBinds ss $
@@ -587,28 +645,36 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
                      ; repPragRule n' bndrs' lhs' rhs' act' }
        ; rule2 <- wrapGenSyms ss rule1
        ; return (loc, rule2) }
+repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
 
 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig n sig))
-  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
+ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig _ n sig))
+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
   = unLoc n : vars
+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+  = panic "ruleBndrNames"
+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+  = panic "ruleBndrNames"
+ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames"
 
 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (L _ (RuleBndr n))
+repRuleBndr (L _ (RuleBndr _ n))
   = do { MkC n' <- lookupLBinder n
        ; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig n sig))
+repRuleBndr (L _ (RuleBndrSig _ n sig))
   = do { MkC n'  <- lookupLBinder n
        ; MkC ty' <- repLTy (hsSigWcType sig)
        ; rep2 typedRuleVarName [n', ty'] }
+repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr"
 
 repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
   = do { target <- repAnnProv ann_prov
        ; exp'   <- repE exp
        ; dec    <- repPragAnn target exp'
        ; return (loc, dec) }
+repAnnD (L _ (XAnnDecl _)) = panic "repAnnD"
 
 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
 repAnnProv (ValueAnnProvenance (L _ n))
@@ -626,51 +692,48 @@ repAnnProv ModuleAnnProvenance
 
 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = Nothing, con_cxt = Nothing
-                      , con_details = details }))
-  = repDataCon con details
+                      , con_forall = L _ False
+                      , con_mb_cxt = Nothing
+                      , con_args = args }))
+  = repDataCon con args
 
 repC (L _ (ConDeclH98 { con_name = con
-                      , con_qvars = mcon_tvs, con_cxt = mcxt
-                      , con_details = details }))
-  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
-             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
-       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
-         do { c'    <- repDataCon con details
-            ; ctxt' <- repContext ctxt
-            ; if isEmptyLHsQTvs con_tvs && null ctxt
+                      , con_forall = L _ is_existential
+                      , con_ex_tvs = con_tvs
+                      , con_mb_cxt = mcxt
+                      , con_args = args }))
+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
               then return c'
               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
             }
        }
 
 repC (L _ (ConDeclGADT { con_names = cons
-                       , con_type = res_ty@(HsIB { hsib_vars = imp_tvs })}))
-  | (details, res_ty', L _ [] , []) <- gadtDetails
-  , [] <- imp_tvs
-    -- no implicit or explicit variables, no context = no need for a forall
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-       ; (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; repGadtDataCons cons hs_details gadt_res_ty }
-
-  | (details,res_ty',ctxt, exp_tvs) <- gadtDetails
-  = do { let doc = text "In the constructor for " <+> ppr (head cons)
-             con_tvs = HsQTvs { hsq_implicit  = imp_tvs
-                              , hsq_explicit  = exp_tvs
-                              , hsq_dependent = emptyNameSet }
-             -- NB: Don't put imp_tvs into the hsq_explicit field above
+                       , con_qvars = qtvs, con_mb_cxt = mcxt
+                       , con_args = args, con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
              -- See Note [Don't quantify implicit type variables in quotes]
-       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
-       { (hs_details, gadt_res_ty) <-
-           updateGadtResult failWithDs doc details res_ty'
-       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
-       ; ctxt' <- repContext (unLoc ctxt)
-       ; if null exp_tvs && null (unLoc ctxt)
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
          then return c'
-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
-  where
-     gadtDetails = gadtDeclDetails res_ty
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repC (L _ (XConDecl _)) = panic "repC"
+
+
+repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext Nothing          = repContext []
+repMbContext (Just (L _ cxt)) = repContext cxt
 
 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
 repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
@@ -691,7 +754,7 @@ repBangTy ty = do
   rep2 bangTypeName [b, t]
   where
     (su', ss', ty') = case ty of
-            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+            L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
             _ -> (NoSrcUnpack, NoSrcStrict, ty)
 
 -------------------------------------------------------
@@ -711,76 +774,108 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
   where
     rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
     rep_deriv_ty (L _ ty) = repTy ty
+repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause"
+
+rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
+               -> DsM ([GenSymBind], [Core TH.DecQ])
+-- Represent signatures and methods in class/instance declarations.
+-- See Note [Scoped type variables in class and instance declarations]
+--
+-- Why not use 'repBinds': we have already created symbols for methods in
+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
+-- these fun_id via 'collectHsValBinders decs', which would lead to the
+-- instance declarations failing in TH.
+rep_sigs_binds sigs binds
+  = do { let tvs = concatMap get_scoped_tvs sigs
+       ; ss <- mkGenSyms tvs
+       ; sigs1 <- addBinds ss $ rep_sigs sigs
+       ; binds1 <- addBinds ss $ rep_binds binds
+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
 
 -------------------------------------------------------
 --   Signatures in a class decl, or a group of bindings
 -------------------------------------------------------
 
-rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ]
-rep_sigs sigs = do locs_cores <- rep_sigs' sigs
-                   return $ de_loc $ sort_by_loc locs_cores
-
-rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
         -- We silently ignore ones we don't recognise
-rep_sigs' = concatMapM rep_sig
+rep_sigs = concatMapM rep_sig
 
 rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms
-rep_sig (L loc (ClassOpSig is_deflt nms ty))
+rep_sig (L loc (TypeSig _ nms ty))    = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (L loc (PatSynSig _ nms ty))  = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
   | is_deflt                          = mapM (rep_ty_sig defaultSigDName loc ty) nms
   | otherwise                         = mapM (rep_ty_sig sigDName 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
-rep_sig (L loc (SpecSig nm tys ispec))
+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (L loc (SpecSig _ nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
+rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
-rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
-
+rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
+rep_sig (L _ (XSig _)) = panic "rep_sig"
 
 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations].
+-- and Note [Don't quantify implicit type variables in quotes]
 rep_ty_sig mk_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
   = do { nm1 <- lookupLOcc nm
-       ; ty1 <- repHsSigType sig_ty
-       ; sig <- repProto mk_sig nm1 ty1
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
+                                    explicit_tvs
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)
+                       then return th_ty
+                       else repTForall th_explicit_tvs th_ctxt th_ty
+       ; sig     <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
+rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
 
 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
                   -> DsM (SrcSpan, Core TH.DecQ)
 -- represents a pattern synonym type signature;
 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
+--
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations]
+-- and Note [Don't quantify implicit type variables in quotes]
 rep_patsyn_ty_sig loc sig_ty nm
-  = do { nm1 <- lookupLOcc nm
-       ; ty1 <- repHsPatSynSigType sig_ty
-       ; sig <- repProto patSynSigDName nm1 ty1
-       ; return (loc, sig) }
-
-rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
-              -> DsM (SrcSpan, Core TH.DecQ)
-    -- We must special-case the top-level explicit for-all of a TypeSig
-    -- See Note [Scoped type variables in bindings]
-rep_wc_ty_sig mk_sig loc sig_ty nm
-  | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
   = do { nm1 <- lookupLOcc nm
        ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                      ; repTyVarBndrWithKind tv name }
-       ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv
-                                    explicit_tvs
+       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
+       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis
+
          -- NB: Don't pass any implicit type variables to repList above
          -- See Note [Don't quantify implicit type variables in quotes]
 
-       ; th_ctxt <- repLContext ctxt
-       ; th_ty   <- repLTy ty
-       ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
-                then return th_ty
-                else repTForall th_explicit_tvs th_ctxt th_ty
-       ; sig <- repProto mk_sig nm1 ty1
+       ; th_reqs  <- repLContext reqs
+       ; th_provs <- repLContext provs
+       ; th_ty    <- repLTy ty
+       ; ty1      <- repTForall th_univs th_reqs =<<
+                       repTForall th_exis th_provs th_ty
+       ; sig      <- repProto patSynSigDName nm1 ty1
        ; return (loc, sig) }
+rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
+
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
+              -> DsM (SrcSpan, Core TH.DecQ)
+rep_wc_ty_sig mk_sig loc sig_ty nm
+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
 
 rep_inline :: Located Name
            -> InlinePragma      -- Never defaultInlinePragma
@@ -803,7 +898,7 @@ rep_specialise nm ty ispec loc
        ; ty1 <- repHsSigType ty
        ; phases <- repPhases $ inl_act ispec
        ; let inline = inl_inline ispec
-       ; pragma <- if isEmptyInlineSpec inline
+       ; pragma <- if noUserInlineSpec inline
                    then -- SPECIALISE
                      repPragSpec nm1 ty1 phases
                    else -- SPECIALISE INLINE
@@ -863,27 +958,35 @@ addSimpleTyVarBinds names thing_inside
        ; term <- addBinds fresh_names thing_inside
        ; wrapGenSyms fresh_names term }
 
+addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
+                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+                -> DsM (Core (TH.Q a))
+addHsTyVarBinds exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
+       ; term <- addBinds fresh_exp_names $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
+                    ; thing_inside kbs }
+       ; wrapGenSyms fresh_exp_names term }
+  where
+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+
 addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
-              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
+              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
 -- meta environment and gets the *new* names on Core-level as an argument
-
-addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
-  = do { fresh_imp_names <- mkGenSyms imp_tvs
-       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
-       ; let fresh_names = fresh_imp_names ++ fresh_exp_names
-       ; term <- addBinds fresh_names $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
-                                     (exp_tvs `zip` fresh_exp_names)
-                    ; m kbs }
-       ; wrapGenSyms fresh_names term }
-  where
-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
+                      , hsq_explicit = exp_tvs })
+              thing_inside
+  = addSimpleTyVarBinds imp_tvs $
+    addHsTyVarBinds exp_tvs $
+    thing_inside
+addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
 
 addTyClTyVarBinds :: LHsQTyVars GhcRn
-                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
+                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
                   -> DsM (Core (TH.Q a))
 
 -- Used for data/newtype declarations, and family instances,
@@ -899,30 +1002,34 @@ addTyClTyVarBinds tvs m
             -- This makes things work for family declarations
 
        ; term <- addBinds freshNames $
-                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (hsQTvExplicit tvs)
                     ; m kbs }
 
        ; wrapGenSyms freshNames term }
   where
+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
     mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
                        ; repTyVarBndrWithKind tv v }
 
 -- Produce kinded binder constructors from the Haskell tyvar binders
 --
 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar _)) nm
+                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
-  = repLKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
+  = repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
 
 -- | Represent a type variable binder
-repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndr)
-repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
-                                             ; repPlainTV nm' }
-repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
-                                                  ; ki' <- repLKind ki
-                                                  ; repKindedTV nm' ki' }
+repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
+                                               ; repPlainTV nm' }
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
+                                                    ; ki' <- repLTy ki
+                                                    ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
 
 -- represent a type context
 --
@@ -934,43 +1041,23 @@ repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
                      repCtxt preds
 
 repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
-repHsSigType (HsIB { hsib_vars = implicit_tvs
+repHsSigType (HsIB { hsib_ext = implicit_tvs
                    , hsib_body = body })
   | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
-  = addTyVarBinds (HsQTvs { hsq_implicit = implicit_tvs
-                          , hsq_explicit = explicit_tvs
-                          , hsq_dependent = emptyNameSet })
-    -- NB: Don't pass implicit_tvs to the hsq_explicit field above
-    -- See Note [Don't quantify implicit type variables in quotes]
-                  $ \ th_explicit_tvs ->
+  = addSimpleTyVarBinds implicit_tvs $
+      -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
     do { th_ctxt <- repLContext ctxt
        ; th_ty   <- repLTy ty
        ; if null explicit_tvs && null (unLoc ctxt)
          then return th_ty
          else repTForall th_explicit_tvs th_ctxt th_ty }
-
-repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
-repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
-                         , hsib_body = body })
-  = addTyVarBinds (newTvs implicit_tvs univs) $ \th_univs ->
-      addTyVarBinds (newTvs [] exis) $ \th_exis ->
-    do { th_reqs  <- repLContext reqs
-       ; th_provs <- repLContext provs
-       ; th_ty    <- repLTy ty
-       ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
-  where
-    newTvs impl_tvs expl_tvs = HsQTvs
-      { hsq_implicit  = impl_tvs
-      , hsq_explicit  = expl_tvs
-      , hsq_dependent = emptyNameSet }
-    -- NB: Don't pass impl_tvs to the hsq_explicit field above
-    -- See Note [Don't quantify implicit type variables in quotes]
-
-    (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
+repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
 
 repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
 repHsSigWcType (HsWC { hswc_body = sig1 })
   = repHsSigType sig1
+repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
 
 -- yield the representation of a list of types
 repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
@@ -984,8 +1071,7 @@ repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
 -- Arg of repForall is always HsForAllTy or HsQualTy
 repForall ty
  | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
- = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
-                         , hsq_dependent = emptyNameSet }) $ \bndrs ->
+ = addHsTyVarBinds tvs $ \bndrs ->
    do { ctxt1  <- repLContext ctxt
       ; ty1    <- repLTy tau
       ; repTForall bndrs ctxt1 ty1 }
@@ -994,7 +1080,10 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
 repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
-repTy (HsTyVar _ (L _ n))
+repTy (HsTyVar _ _ (L _ n))
+  | isLiftedTypeKindTyConName n       = repTStar
+  | n `hasKey` constraintKindTyConKey = repTConstraint
+  | n `hasKey` funTyConKey            = repArrowTyCon
   | isTvOcc occ   = do tv1 <- lookupOcc n
                        repTvar tv1
   | isDataOcc occ = do tc1 <- lookupOcc n
@@ -1005,47 +1094,38 @@ repTy (HsTyVar _ (L _ n))
   where
     occ = nameOccName n
 
-repTy (HsAppTy f a)         = do
+repTy (HsAppTy _ f a)       = do
                                 f1 <- repLTy f
                                 a1 <- repLTy a
                                 repTapp f1 a1
-repTy (HsFunTy f a)         = do
+repTy (HsFunTy _ f a)       = do
                                 f1   <- repLTy f
                                 a1   <- repLTy a
                                 tcon <- repArrowTyCon
                                 repTapps tcon [f1, a1]
-repTy (HsListTy t)          = do
+repTy (HsListTy _ t)        = do
                                 t1   <- repLTy t
                                 tcon <- repListTyCon
                                 repTapp tcon t1
-repTy (HsPArrTy t)     = do
-                           t1   <- repLTy t
-                           tcon <- repTy (HsTyVar NotPromoted
-                                                  (noLoc (tyConName parrTyCon)))
-                           repTapp tcon t1
-repTy (HsTupleTy HsUnboxedTuple tys) = do
+repTy (HsTupleTy _ HsUnboxedTuple tys) = do
                                 tys1 <- repLTys tys
                                 tcon <- repUnboxedTupleTyCon (length tys)
                                 repTapps tcon tys1
-repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
                                  tcon <- repTupleTyCon (length tys)
                                  repTapps tcon tys1
-repTy (HsSumTy tys)         = do tys1 <- repLTys tys
+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
                                  tcon <- repUnboxedSumTyCon (length tys)
                                  repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                    `nlHsAppTy` ty2)
-repTy (HsParTy t)           = repLTy t
-repTy (HsEqTy t1 t2) = do
-                         t1' <- repLTy t1
-                         t2' <- repLTy t2
-                         eq  <- repTequality
-                         repTapps eq [t1', t2']
-repTy (HsKindSig t k)       = do
+repTy (HsParTy _ t)         = repLTy t
+repTy (HsStarTy _ _) =  repTStar
+repTy (HsKindSig _ t k)     = do
                                 t1 <- repLTy t
-                                k1 <- repLKind k
+                                k1 <- repLTy k
                                 repTSig t1 k1
-repTy (HsSpliceTy splice _)     = repSplice splice
+repTy (HsSpliceTy _ splice)      = repSplice splice
 repTy (HsExplicitListTy _ _ tys) = do
                                     tys1 <- repLTys tys
                                     repTPromotedList tys1
@@ -1053,10 +1133,14 @@ repTy (HsExplicitTupleTy _ tys) = do
                                     tys1 <- repLTys tys
                                     tcon <- repPromotedTupleTyCon (length tys)
                                     repTapps tcon tys1
-repTy (HsTyLit lit) = do
-                        lit' <- repTyLit lit
-                        repTLit lit'
+repTy (HsTyLit _ lit) = do
+                          lit' <- repTyLit lit
+                          repTLit lit'
 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
+repTy (HsIParamTy _ n t) = do
+                             n' <- rep_implicit_param_name (unLoc n)
+                             t' <- repLTy t
+                             repTImplicitParam n' t'
 
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
@@ -1067,59 +1151,14 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                             ; rep2 strTyLitName [s']
                             }
 
--- represent a kind
---
--- It would be great to scrap this function in favor of repLTy, since Types
--- and Kinds are the same things. We have not done so yet for engineering
--- reasons, as repLTy returns a monadic TypeQ, whereas repLKind returns a pure
--- Kind, so in order to replace repLKind with repLTy, we'd need to go through
--- and purify repLTy and every monadic function it calls. This is the subject
--- GHC Trac #11785.
-repLKind :: LHsKind GhcRn -> DsM (Core TH.Kind)
-repLKind ki
-  = do { let (kis, ki') = splitHsFunType ki
-       ; kis_rep <- mapM repLKind kis
-       ; ki'_rep <- repNonArrowLKind ki'
-       ; kcon <- repKArrow
-       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
-       ; foldrM f ki'_rep kis_rep
-       }
-
--- | Represent a kind wrapped in a Maybe
-repMaybeLKind :: Maybe (LHsKind GhcRn)
-              -> DsM (Core (Maybe TH.Kind))
-repMaybeLKind Nothing =
-    do { coreNothing kindTyConName }
-repMaybeLKind (Just ki) =
-    do { ki' <- repLKind ki
-       ; coreJust kindTyConName ki' }
-
-repNonArrowLKind :: LHsKind GhcRn -> DsM (Core TH.Kind)
-repNonArrowLKind (L _ ki) = repNonArrowKind ki
-
-repNonArrowKind :: HsKind GhcRn -> DsM (Core TH.Kind)
-repNonArrowKind (HsTyVar _ (L _ name))
-  | isLiftedTypeKindTyConName name       = repKStar
-  | name `hasKey` constraintKindTyConKey = repKConstraint
-  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
-  | otherwise                       = lookupOcc name >>= repKCon
-repNonArrowKind (HsAppTy f a)       = do  { f' <- repLKind f
-                                          ; a' <- repLKind a
-                                          ; repKApp f' a'
-                                          }
-repNonArrowKind (HsListTy k)        = do  { k' <- repLKind k
-                                          ; kcon <- repKList
-                                          ; repKApp kcon k'
-                                          }
-repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks
-                                          ; kcon <- repKTuple (length ks)
-                                          ; repKApps kcon ks'
-                                          }
-repNonArrowKind (HsKindSig k sort)  = do  { k'    <- repLKind k
-                                          ; sort' <- repLKind sort
-                                          ; repKSig k' sort'
-                                          }
-repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)
+-- | Represent a type wrapped in a Maybe
+repMaybeLTy :: Maybe (LHsKind GhcRn)
+            -> DsM (Core (Maybe TH.TypeQ))
+repMaybeLTy Nothing =
+    do { coreNothing kindQTyConName }
+repMaybeLTy (Just ki) =
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
 
 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
 repRole (L _ (Just Nominal))          = rep2 nominalRName []
@@ -1134,10 +1173,11 @@ repRole (L _ Nothing)                 = rep2 inferRName []
 repSplice :: HsSplice GhcRn -> DsM (Core a)
 -- See Note [How brackets and nested splices are handled] in TcSplice
 -- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice   _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ n _) = rep_splice n
-repSplice (HsQuasiQuote n _ _ _)  = rep_splice n
-repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)
 
 rep_splice :: Name -> DsM (Core a)
 rep_splice splice_name
@@ -1162,7 +1202,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
 repLE (L loc e) = putSrcSpanDs loc (repE e)
 
 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar (L _ x))            =
+repE (HsVar _ (L _ x))            =
   do { mb_val <- dsLookupMetaEnv x
      ; case mb_val of
         Nothing            -> do { str <- globalVar x
@@ -1170,45 +1210,46 @@ repE (HsVar (L _ x))            =
         Just (DsBound y)   -> repVarOrCon x (coreVar y)
         Just (DsSplice e)  -> do { e' <- dsExpr e
                                  ; return (MkC e') } }
-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-repE (HsOverLabel _ s) = repOverLabel s
+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
+repE (HsOverLabel _ _ s) = repOverLabel s
 
-repE e@(HsRecFld f) = case f of
-  Unambiguous _ x -> repE (HsVar (noLoc x))
+repE e@(HsRecFld _ f) = case f of
+  Unambiguous x _ -> repE (HsVar noExt (noLoc x))
   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
 
         -- Remember, we're desugaring renamer output here, so
         -- HsOverlit can definitely occur
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
-repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
-repE (HsLamCase (MG { mg_alts = L _ ms }))
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = L _ ms }))
                    = do { ms' <- mapM repMatchTup ms
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
-repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType e t) = do { a <- repLE e
+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType t e) = do { a <- repLE e
                           ; s <- repLTy (hswc_body t)
                           ; repAppType a s }
 
-repE (OpApp e1 op _ e2) =
+repE (OpApp _ e1 op e2) =
   do { arg1 <- repLE e1;
        arg2 <- repLE e2;
        the_op <- repLE op ;
        repInfixApp arg1 the_op arg2 }
-repE (NegApp x _)        = do
+repE (NegApp _ x _)      = do
                               a         <- repLE x
                               negateVar <- lookupOcc negateName >>= repVar
                               negateVar `repApp` a
-repE (HsPar x)            = repLE x
-repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MG { mg_alts = L _ ms }))
+repE (HsPar _ x)            = repLE x
+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = L _ ms }))
                           = do { arg <- repLE e
                                ; ms2 <- mapM repMatchTup ms
                                ; core_ms2 <- coreList matchQTyConName ms2
                                ; repCaseE arg core_ms2 }
-repE (HsIf _ x y z)         = do
+repE (HsIf _ _ x y z)       = do
                               a <- repLE x
                               b <- repLE y
                               c <- repLE z
@@ -1217,13 +1258,13 @@ repE (HsMultiIf _ alts)
   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
        ; expr' <- repMultiIf (nonEmptyCoreList alts')
        ; wrapGenSyms (concat binds) expr' }
-repE (HsLet (L _ bs) e)         = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs
                                      ; e2 <- addBinds ss (repLE e)
                                      ; z <- repLetE ds e2
                                      ; wrapGenSyms ss z }
 
 -- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt (L _ sts) _)
+repE e@(HsDo _ ctxt (L _ sts))
  | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts;
         e'      <- repDoE (nonEmptyCoreList zs);
@@ -1234,18 +1275,22 @@ repE e@(HsDo ctxt (L _ sts) _)
         e'      <- repComp (nonEmptyCoreList zs);
         wrapGenSyms ss e' }
 
+ | MDoExpr <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repMDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
   | otherwise
-  = notHandled "mdo, monad comprehension and [: :]" (ppr e)
+  = notHandled "monad comprehension and [: :]" (ppr e)
 
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
-repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
-repE e@(ExplicitTuple es boxed)
+repE e@(ExplicitTuple _ es boxed)
   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
-  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
-                        ; repUnboxedTup xs }
+  | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+                       ; repUnboxedTup xs }
 
-repE (ExplicitSum alt arity e _)
+repE (ExplicitSum _ alt arity e)
  = do { e1 <- repLE e
       ; repUnboxedSum e1 alt arity }
 
@@ -1258,7 +1303,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
         fs <- repUpdFields flds;
         repRecUpd x fs }
 
-repE (ExprWithTySig e ty)
+repE (ExprWithTySig ty e)
   = do { e1 <- repLE e
        ; t1 <- repHsSigWcType ty
        ; repSigExp e1 t1 }
@@ -1280,25 +1325,24 @@ repE (ArithSeq _ _ aseq) =
                              ds3 <- repLE e3
                              repFromThenTo ds1 ds2 ds3
 
-repE (HsSpliceE splice)    = repSplice splice
+repE (HsSpliceE _ splice)  = repSplice splice
 repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar uv)     = do
+repE (HsUnboundVar _ uv)   = do
                                occ   <- occNameLit (unboundVarOcc uv)
                                sname <- repNameS occ
                                repUnboundVar sname
 
-repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)
 repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
 repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
 repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)
-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
 repE e                     = notHandled "Expression form" (ppr e)
 
 -----------------------------------------------------------------------------
 -- Building representations of auxillary structures like Match, Clause, Stmt,
 
 repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
+repMatchTup (L _ (Match { m_pats = [p]
+                        , m_grhss = GRHSs _ guards (L _ wheres) })) =
   do { ss1 <- mkGenSyms (collectPatBinders p)
      ; addBinds ss1 $ do {
      ; p1 <- repLP p
@@ -1310,7 +1354,8 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 
 repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =
+repClauseTup (L _ (Match { m_pats = ps
+                         , m_grhss = GRHSs _ guards (L _ wheres) })) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps)
      ; addBinds ss1 $ do {
        ps1 <- repLPs ps
@@ -1319,9 +1364,11 @@ repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =
        gs <- repGuards guards
      ; clause <- repClause ps1 gs ds
      ; wrapGenSyms (ss1++ss2) clause }}}
+repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
+repClauseTup (L _ (XMatch _)) = panic "repClauseTup"
 
 repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [] e)]
+repGuards [L _ (GRHS _ [] e)]
   = do {a <- repLE e; repNormal a }
 repGuards other
   = do { zs <- mapM repLGRHS other
@@ -1331,14 +1378,15 @@ repGuards other
 
 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
          -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
   = do { guarded <- repLNormalGE e1 e2
        ; return ([], guarded) }
-repLGRHS (L _ (GRHS ss rhs))
+repLGRHS (L _ (GRHS _ ss rhs))
   = do { (gs, ss') <- repLSts ss
        ; rhs' <- addBinds gs $ repLE rhs
        ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
        ; return (gs, guarded) }
+repLGRHS (L _ (XGRHS _)) = panic "repLGRHS"
 
 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
@@ -1355,7 +1403,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
   where
     rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
     rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
-      Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
                                    ; e  <- repLE (hsRecFieldArg fld)
                                    ; repFieldExp fn e }
       _                      -> notHandled "Ambiguous record updates" (ppr fld)
@@ -1391,7 +1439,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repLSts stmts = repSts (map unLoc stmts)
 
 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts (BindStmt p e _ _ _ : ss) =
+repSts (BindStmt _ p e _ _ : ss) =
    do { e2 <- repLE e
       ; ss1 <- mkGenSyms (collectPatBinders p)
       ; addBinds ss1 $ do {
@@ -1399,17 +1447,17 @@ repSts (BindStmt p e _ _ _ : ss) =
       ; (ss2,zs) <- repSts ss
       ; z <- repBindSt p1 e2
       ; return (ss1++ss2, z : zs) }}
-repSts (LetStmt (L _ bs) : ss) =
+repSts (LetStmt _ (L _ bs) : ss) =
    do { (ss1,ds) <- repBinds bs
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
       ; return (ss1++ss2, z : zs) }
-repSts (BodyStmt e _ _ _ : ss) =
+repSts (BodyStmt _ e _ _ : ss) =
    do { e2 <- repLE e
       ; z <- repNoBindSt e2
       ; (ss2,zs) <- repSts ss
       ; return (ss2, z : zs) }
-repSts (ParStmt stmt_blocks _ _ _ : ss) =
+repSts (ParStmt _ stmt_blocks _ _ : ss) =
    do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
       ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
             ss1 = concat ss_s
@@ -1419,14 +1467,25 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
    where
      rep_stmt_block :: ParStmtBlock GhcRn GhcRn
                     -> DsM ([GenSymBind], Core [TH.StmtQ])
-     rep_stmt_block (ParStmtBlock stmts _ _) =
+     rep_stmt_block (ParStmtBlock _ stmts _ _) =
        do { (ss1, zs) <- repSts (map unLoc stmts)
           ; zs1 <- coreList stmtQTyConName zs
           ; return (ss1, zs1) }
-repSts [LastStmt e _ _]
+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"
+repSts [LastStmt _ e _ _]
   = do { e2 <- repLE e
        ; z <- repNoBindSt e2
        ; return ([], [z]) }
+repSts (stmt@RecStmt{} : ss)
+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)
+       ; ss1 <- mkGenSyms binders
+       -- Bring all of binders in the recursive group into scope for the
+       -- whole group.
+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
+       ; MASSERT(sort ss1 == sort ss1_other)
+       ; z <- repRecSt (nonEmptyCoreList rss)
+       ; (ss2,zs) <- addBinds ss1 (repSts ss)
+       ; return (ss1++ss2, z : zs) }
 repSts []    = return ([],[])
 repSts other = notHandled "Exotic statement" (ppr other)
 
@@ -1436,40 +1495,60 @@ repSts other = notHandled "Exotic statement" (ppr other)
 -----------------------------------------------------------
 
 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
-repBinds EmptyLocalBinds
+repBinds (EmptyLocalBinds _)
   = do  { core_list <- coreList decQTyConName []
         ; return ([], core_list) }
 
-repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
+repBinds (HsIPBinds _ (IPBinds _ decs))
+ = do   { ips <- mapM rep_implicit_param_bind decs
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc ips))
+        ; return ([], core_list)
+        }
+
+repBinds b@(HsIPBinds _ XHsIPBinds {})
+ = notHandled "Implicit parameter binds extension" (ppr b)
 
-repBinds (HsValBinds decs)
- = do   { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
+repBinds (HsValBinds _ decs)
+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
                 -- No need to worry about detailed scopes within
                 -- the binding group, because we are talking Names
                 -- here, so we can safely treat it as a mutually
                 -- recursive group
-                -- For hsSigTvBinders see Note [Scoped type variables in bindings]
+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
         ; ss        <- mkGenSyms bndrs
         ; prs       <- addBinds ss (rep_val_binds decs)
         ; core_list <- coreList decQTyConName
                                 (de_loc (sort_by_loc prs))
         ; return (ss, core_list) }
+repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
+
+rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
+ = do { name <- case ename of
+                    Left (L _ n) -> rep_implicit_param_name n
+                    Right _ ->
+                        panic "rep_implicit_param_bind: post typechecking"
+      ; rhs' <- repE rhs
+      ; ipb <- repImplicitParamBind name rhs'
+      ; return (loc, ipb) }
+rep_implicit_param_bind (L _ b@(XIPBind _))
+ = notHandled "Implicit parameter bind extension" (ppr b)
+
+rep_implicit_param_name :: HsIPName -> DsM (Core String)
+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
 
 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (ValBindsOut binds sigs)
- = do { core1 <- rep_binds' (unionManyBags (map snd binds))
-      ; core2 <- rep_sigs' sigs
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
+ = do { core1 <- rep_binds (unionManyBags (map snd binds))
+      ; core2 <- rep_sigs sigs
       ; return (core1 ++ core2) }
-rep_val_binds (ValBindsIn _ _)
- = panic "rep_val_binds: ValBindsIn"
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
 
-rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ]
-rep_binds binds = do { binds_w_locs <- rep_binds' binds
-                     ; return (de_loc (sort_by_loc binds_w_locs)) }
-
-rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_binds' = mapM rep_bind . bagToList
+rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds = mapM rep_bind . bagToList
 
 rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
 -- Assumes: all the binders of the binding are already in the meta-env
@@ -1480,8 +1559,10 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
 rep_bind (L loc (FunBind
                  { fun_id = fn,
                    fun_matches = MG { mg_alts
-                           = L _ [L _ (Match _ [] _
-                                             (GRHSs guards (L _ wheres)))] } }))
+                           = L _ [L _ (Match
+                                       { m_pats = []
+                                       , m_grhss = GRHSs _ guards (L _ wheres) }
+                                      )] } }))
  = do { (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; fn'  <- lookupLBinder fn
@@ -1497,14 +1578,17 @@ rep_bind (L loc (FunBind { fun_id = fn
         ; ans <- repFun fn' (nonEmptyCoreList ms1)
         ; return (loc, ans) }
 
+rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
+
 rep_bind (L loc (PatBind { pat_lhs = pat
-                         , pat_rhs = GRHSs guards (L _ wheres) }))
+                         , pat_rhs = GRHSs _ guards (L _ wheres) }))
  =   do { patcore <- repLP pat
         ; (ss,wherecore) <- repBinds wheres
         ; guardcore <- addBinds ss (repGuards guards)
         ; ans  <- repVal patcore guardcore wherecore
         ; ans' <- wrapGenSyms ss ans
         ; return (loc, ans') }
+rep_bind (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
 
 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
  =   do { v' <- lookupBinder v
@@ -1516,12 +1600,10 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
-rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
-rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
-                                 , psb_fvs  = _fvs
-                                 , psb_args = args
-                                 , psb_def  = pat
-                                 , psb_dir  = dir })))
+rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
+                                   , psb_args = args
+                                   , psb_def  = pat
+                                   , psb_dir  = dir })))
   = do { syn'      <- lookupLBinder syn
        ; dir'      <- repPatSynDir dir
        ; ss        <- mkGenArgSyms args
@@ -1538,10 +1620,10 @@ rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
     -- API. Whereas inside GHC, record pattern synonym selectors and
     -- their pattern-only bound right hand sides have different names,
     -- we want to treat them the same in TH. This is the reason why we
-    -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
-    mkGenArgSyms (PrefixPatSyn args)     = mkGenSyms (map unLoc args)
-    mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
-    mkGenArgSyms (RecordPatSyn fields)
+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecCon fields)
       = do { let pats = map (unLoc . recordPatSynPatVar) fields
                  sels = map (unLoc . recordPatSynSelectorId) fields
            ; ss <- mkGenSyms sels
@@ -1553,8 +1635,11 @@ rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
 
     wrapGenArgSyms :: HsPatSynDetails (Located Name)
                    -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
-    wrapGenArgSyms (RecordPatSyn _) _  dec = return dec
-    wrapGenArgSyms _                ss dec = wrapGenSyms ss dec
+    wrapGenArgSyms (RecCon _) _  dec = return dec
+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
+
+rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
+rep_bind (L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"
 
 repPatSynD :: Core TH.Name
            -> Core TH.PatSynArgsQ
@@ -1565,14 +1650,14 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
   = rep2 patSynDName [syn, args, dir, pat]
 
 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
-repPatSynArgs (PrefixPatSyn args)
+repPatSynArgs (PrefixCon args)
   = do { args' <- repList nameTyConName lookupLOcc args
        ; repPrefixPatSynArgs args' }
-repPatSynArgs (InfixPatSyn arg1 arg2)
+repPatSynArgs (InfixCon arg1 arg2)
   = do { arg1' <- lookupLOcc arg1
        ; arg2' <- lookupLOcc arg2
        ; repInfixPatSynArgs arg1' arg2' }
-repPatSynArgs (RecordPatSyn fields)
+repPatSynArgs (RecCon fields)
   = do { sels' <- repList nameTyConName lookupLOcc sels
        ; repRecordPatSynArgs sels' }
   where sels = map recordPatSynSelectorId fields
@@ -1593,6 +1678,7 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
 repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
   = do { clauses' <- mapM repClauseTup clauses
        ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
 
 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
@@ -1623,7 +1709,9 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
 -- (\ p1 .. pn -> exp) by causing an error.
 
 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
+repLambda (L _ (Match { m_pats = ps
+                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+                                          (L _ (EmptyLocalBinds _)) } ))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -1648,19 +1736,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
 repLP (L _ p) = repP p
 
 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
-repP (WildPat _)       = repPwild
-repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat (L _ x))  = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
-repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p)        = repLP p
-repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
-repP (TuplePat ps boxed _)
+repP (WildPat _)        = repPwild
+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p
+                             ; repPaspat x' p1 }
+repP (ParPat _ p)       = repLP p
+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
+                                ; e' <- repE (syn_expr e)
+                                ; repPview e' p}
+repP (TuplePat _ ps boxed)
   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
-repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+                                 ; repPunboxedSum p1 alt arity }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
@@ -1677,13 +1769,13 @@ repP (ConPatIn dc details)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
-repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPatIn p t) = do { p' <- repLP p
-                         ; t' <- repLTy (hsSigWcType t)
-                         ; repPsig p' t' }
-repP (SplicePat splice) = repSplice splice
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat t p) = do { p' <- repLP p
+                       ; t' <- repLTy (hsSigWcType t)
+                       ; repPsig p' t' }
+repP (SplicePat _ splice) = repSplice splice
 
 repP other = notHandled "Exotic pattern" (ppr other)
 
@@ -1836,7 +1928,7 @@ unC (MkC x) = x
 
 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 rep2 n xs = do { id <- dsLookupGlobalId n
-               ; return (MkC (foldl App (Var id) xs)) }
+               ; return (MkC (foldl' App (Var id) xs)) }
 
 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
 dataCon' n args = do { id <- dsLookupDataCon n
@@ -1958,6 +2050,9 @@ repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 repDoE (MkC ss) = rep2 doEName [ss]
 
+repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repMDoE (MkC ss) = rep2 mdoEName [ss]
+
 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 repComp (MkC ss) = rep2 compEName [ss]
 
@@ -1985,6 +2080,9 @@ repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 
+repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
+
 ------------ Right hand sides (guarded expressions) ----
 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
@@ -2018,6 +2116,9 @@ repNoBindSt (MkC e) = rep2 noBindSName [e]
 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
 repParSt (MkC sss) = rep2 parSName [sss]
 
+repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
+repRecSt (MkC ss) = rep2 recSName [ss]
+
 -------------- Range (Arithmetic sequences) -----------
 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repFrom (MkC x) = rep2 fromEName [x]
@@ -2045,8 +2146,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+        -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
         -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
   = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
@@ -2054,8 +2155,8 @@ repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
         (MkC derivs)
   = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
 
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
-           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind)
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+           -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
            -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
            (MkC derivs)
@@ -2064,7 +2165,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
            (MkC derivs)
   = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
 
-repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
   = rep2 tySynDName [nm, tvs, rhs]
@@ -2074,19 +2175,34 @@ repInst :: Core (Maybe TH.Overlap) ->
 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
                                                               [o, cxt, ty, ds]
 
-repDerivStrategy :: Maybe (Located DerivStrategy)
-                 -> DsM (Core (Maybe TH.DerivStrategy))
+repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
+                 -> DsM (Core (Maybe TH.DerivStrategyQ))
 repDerivStrategy mds =
   case mds of
     Nothing -> nothing
     Just (L _ ds) ->
       case ds of
-        StockStrategy    -> just =<< dataCon stockStrategyDataConName
-        AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName
-        NewtypeStrategy  -> just =<< dataCon newtypeStrategyDataConName
+        StockStrategy    -> just =<< repStockStrategy
+        AnyclassStrategy -> just =<< repAnyclassStrategy
+        NewtypeStrategy  -> just =<< repNewtypeStrategy
+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)
+                               via_strat <- repViaStrategy ty'
+                               just via_strat
   where
-  nothing = coreNothing derivStrategyTyConName
-  just    = coreJust    derivStrategyTyConName
+  nothing = coreNothing derivStrategyQTyConName
+  just    = coreJust    derivStrategyQTyConName
+
+repStockStrategy :: DsM (Core TH.DerivStrategyQ)
+repStockStrategy = rep2 stockStrategyName []
+
+repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
+repAnyclassStrategy = rep2 anyclassStrategyName []
+
+repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
+repNewtypeStrategy = rep2 newtypeStrategyName []
+
+repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
+repViaStrategy (MkC t) = rep2 viaStrategyName [t]
 
 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
 repOverlap mb =
@@ -2104,13 +2220,13 @@ repOverlap mb =
   just    = coreJust overlapTyConName
 
 
-repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
          -> Core [TH.FunDep] -> Core [TH.DecQ]
          -> DsM (Core TH.DecQ)
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
   = rep2 classDName [cxt, cls, tvs, fds, ds]
 
-repDeriv :: Core (Maybe TH.DerivStrategy)
+repDeriv :: Core (Maybe TH.DerivStrategyQ)
          -> Core TH.CxtQ -> Core TH.TypeQ
          -> DsM (Core TH.DecQ)
 repDeriv (MkC ds) (MkC cxt) (MkC ty)
@@ -2149,22 +2265,22 @@ repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
 repTySynInst (MkC nm) (MkC eqn)
     = rep2 tySynInstDName [nm, eqn]
 
-repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndr]
-               -> Core (Maybe TH.Kind) -> DsM (Core TH.DecQ)
+repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
+               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
     = rep2 dataFamilyDName [nm, tvs, kind]
 
 repOpenFamilyD :: Core TH.Name
-               -> Core [TH.TyVarBndr]
-               -> Core TH.FamilyResultSig
+               -> Core [TH.TyVarBndrQ]
+               -> Core TH.FamilyResultSigQ
                -> Core (Maybe TH.InjectivityAnn)
                -> DsM (Core TH.DecQ)
 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
     = rep2 openTypeFamilyDName [nm, tvs, result, inj]
 
 repClosedFamilyD :: Core TH.Name
-                 -> Core [TH.TyVarBndr]
-                 -> Core TH.FamilyResultSig
+                 -> Core [TH.TyVarBndrQ]
+                 -> Core TH.FamilyResultSigQ
                  -> Core (Maybe TH.InjectivityAnn)
                  -> Core [TH.TySynEqnQ]
                  -> DsM (Core TH.DecQ)
@@ -2184,6 +2300,9 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 
+repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
+
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
@@ -2234,7 +2353,7 @@ repConstr (RecCon (L _ ips)) resTy cons
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
 
       rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
-      rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)
+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)
                           ; MkC ty <- repBangTy  t
                           ; rep2 varBangTypeName [v,ty] }
 
@@ -2250,7 +2369,7 @@ repConstr _ _ _ =
 
 ------------ Types -------------------
 
-repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
+repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
            -> DsM (Core TH.TypeQ)
 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
     = rep2 forallTName [tvars, ctxt, ty]
@@ -2265,7 +2384,7 @@ repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTapps f []     = return f
 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 
-repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
+repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
 
 repTequality :: DsM (Core TH.TypeQ)
@@ -2285,6 +2404,15 @@ repTLit (MkC lit) = rep2 litTName [lit]
 repTWildCard :: DsM (Core TH.TypeQ)
 repTWildCard = rep2 wildCardTName []
 
+repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
+
+repTStar :: DsM (Core TH.TypeQ)
+repTStar = rep2 starKName []
+
+repTConstraint :: DsM (Core TH.TypeQ)
+repTConstraint = rep2 constraintKName []
+
 --------- Type constructors --------------
 
 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
@@ -2324,56 +2452,24 @@ repPromotedNilTyCon = rep2 promotedNilTName []
 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
 repPromotedConsTyCon = rep2 promotedConsTName []
 
------------- Kinds -------------------
+------------ TyVarBndrs -------------------
 
-repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
 repPlainTV (MkC nm) = rep2 plainTVName [nm]
 
-repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
+repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
 
-repKVar :: Core TH.Name -> DsM (Core TH.Kind)
-repKVar (MkC s) = rep2 varKName [s]
-
-repKCon :: Core TH.Name -> DsM (Core TH.Kind)
-repKCon (MkC s) = rep2 conKName [s]
-
-repKTuple :: Int -> DsM (Core TH.Kind)
-repKTuple i = do dflags <- getDynFlags
-                 rep2 tupleKName [mkIntExprInt dflags i]
-
-repKArrow :: DsM (Core TH.Kind)
-repKArrow = rep2 arrowKName []
-
-repKList :: DsM (Core TH.Kind)
-repKList = rep2 listKName []
-
-repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
-repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
-
-repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
-repKApps f []     = return f
-repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
-
-repKStar :: DsM (Core TH.Kind)
-repKStar = rep2 starKName []
-
-repKConstraint :: DsM (Core TH.Kind)
-repKConstraint = rep2 constraintKName []
-
-repKSig :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
-repKSig (MkC k) (MkC sort) = rep2 sigTDataConName [k, sort]
-
 ----------------------------------------------------------
 --       Type family result signature
 
-repNoSig :: DsM (Core TH.FamilyResultSig)
+repNoSig :: DsM (Core TH.FamilyResultSigQ)
 repNoSig = rep2 noSigName []
 
-repKindSig :: Core TH.Kind -> DsM (Core TH.FamilyResultSig)
+repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
 repKindSig (MkC ki) = rep2 kindSigName [ki]
 
-repTyVarSig :: Core TH.TyVarBndr -> DsM (Core TH.FamilyResultSig)
+repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
 
 ----------------------------------------------------------
@@ -2416,16 +2512,16 @@ repLiteral lit
 
 mk_integer :: Integer -> DsM (HsLit GhcRn)
 mk_integer  i = do integer_ty <- lookupType integerTyConName
-                   return $ HsInteger noSourceText i integer_ty
+                   return $ HsInteger NoSourceText i integer_ty
 
 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
 mk_rational r = do rat_ty <- lookupType rationalTyConName
-                   return $ HsRat def r rat_ty
+                   return $ HsRat noExt r rat_ty
 mk_string :: FastString -> DsM (HsLit GhcRn)
-mk_string s = return $ HsString noSourceText s
+mk_string s = return $ HsString NoSourceText s
 
 mk_char :: Char -> DsM (HsLit GhcRn)
-mk_char c = return $ HsChar noSourceText c
+mk_char c = return $ HsChar NoSourceText c
 
 repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
 repOverloadedLiteral (OverLit { ol_val = val})
@@ -2433,6 +2529,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
         -- The type Rational will be in the environment, because
         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
         -- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
 
 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
 mk_lit (HsIntegral i)     = mk_integer  (il_value i)
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index c3a29733be..921276e4d8 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -23,13 +23,9 @@ module DsMonad (
         newUnique,
         UniqSupply, newUniqueSupply,
         getGhcModeDs, dsGetFamInstEnvs,
-        dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
         dsLookupDataCon, dsLookupConLike,
 
-        PArrBuiltin(..),
-        dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
-        dsInitPArrBuiltin,
-
         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
 
         -- Getting and setting EvVars and term constraints in local environment
@@ -49,9 +45,14 @@ module DsMonad (
         CanItFail(..), orFail,
 
         -- Levity polymorphism
-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+
+        -- Trace injection
+        pprRuntimeTrace
     ) where
 
+import GhcPrelude
+
 import TcRnMonad
 import FamInstEnv
 import CoreSyn
@@ -60,8 +61,6 @@ import CoreUtils ( exprType, isExprLevPoly )
 import HsSyn
 import TcIface
 import TcMType ( checkForLevPolyX, formatLevPolyErr )
-import LoadIface
-import Finder
 import PrelNames
 import RdrName
 import HscTypes
@@ -81,13 +80,12 @@ import NameEnv
 import DynFlags
 import ErrUtils
 import FastString
-import Maybes
 import Var (EvVar)
-import qualified GHC.LanguageExtensions as LangExt
 import UniqFM ( lookupWithDefaultUFM )
+import Literal ( mkMachString )
+import CostCentreState
 
 import Data.IORef
-import Control.Monad
 
 {-
 ************************************************************************
@@ -106,6 +104,9 @@ instance Outputable DsMatchContext where
 
 data EquationInfo
   = EqnInfo { eqn_pats :: [Pat GhcTc],  -- The patterns for an eqn
+                -- NB: We have /already/ applied decideBangHood to
+                -- these patterns.  See Note [decideBangHood] in DsUtils
+
               eqn_rhs  :: MatchResult } -- What to do after match
 
 instance Outputable EquationInfo where
@@ -159,7 +160,7 @@ initDsTc thing_inside
        ; msg_var  <- getErrsVar
        ; hsc_env  <- getTopEnv
        ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-       ; setEnvs envs $ initDPH thing_inside
+       ; setEnvs envs thing_inside
        }
 
 -- | Run a 'DsM' action inside the 'IO' monad.
@@ -176,6 +177,7 @@ mkDsEnvsFromTcGbl :: MonadIO m
                   -> m (DsGblEnv, DsLclEnv)
 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { pm_iter_var <- liftIO $ newIORef 0
+       ; cc_st_var   <- liftIO $ newIORef newCostCentreState
        ; let dflags   = hsc_dflags hsc_env
              this_mod = tcg_mod tcg_env
              type_env = tcg_type_env tcg_env
@@ -184,13 +186,13 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
              complete_matches = hptCompleteSigs hsc_env
                                 ++ tcg_complete_matches tcg_env
        ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
-                           msg_var pm_iter_var complete_matches
+                           msg_var pm_iter_var cc_st_var complete_matches
        }
 
 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
-                              (initDPH $ tryM thing_inside)
+                              (tryM thing_inside)
        ; msgs   <- readIORef (ds_msgs ds_gbl)
        ; let final_res
                | errorsFound dflags msgs = Nothing
@@ -204,6 +206,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside
 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
 initDsWithModGuts hsc_env guts thing_inside
   = do { pm_iter_var <- newIORef 0
+       ; cc_st_var   <- newIORef newCostCentreState
        ; msg_var <- newIORef emptyMessages
        ; let dflags   = hsc_dflags hsc_env
              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
@@ -219,7 +222,7 @@ initDsWithModGuts hsc_env guts thing_inside
 
              envs  = mkDsEnvs dflags this_mod rdr_env type_env
                               fam_inst_env msg_var pm_iter_var
-                              complete_matches
+                              cc_st_var complete_matches
        ; runDs hsc_env envs thing_inside
        }
 
@@ -247,9 +250,9 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef Int -> [CompleteMatch]
-         -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
+         -> IORef Messages -> IORef Int -> IORef CostCentreState
+         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
          complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
@@ -262,9 +265,8 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
                            , ds_if_env  = (if_genv, if_lenv)
                            , ds_unqual  = mkPrintUnqualified dflags rdr_env
                            , ds_msgs    = msg_var
-                           , ds_dph_env = emptyGlobalRdrEnv
-                           , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
                            , ds_complete_matches = completeMatchMap
+                           , ds_cc_st   = cc_st_var
                            }
         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                            , dsl_loc     = real_span
@@ -490,23 +492,6 @@ mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
     lookupThing = dsLookupGlobal
 
--- | Attempt to load the given module and return its exported entities if
--- successful.
-dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv
-dsLoadModule doc mod
-  = do { env    <- getGblEnv
-       ; setEnvs (ds_if_env env) $ do
-       { iface <- loadInterface doc mod ImportBySystem
-       ; case iface of
-           Failed err      -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)
-           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
-       } }
-  where
-    prov     = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
-    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
-                             is_dloc = wiredInSrcSpan, is_as = name }
-    name = moduleName mod
-
 dsLookupGlobal :: Name -> DsM TyThing
 -- Very like TcEnv.tcLookupGlobal
 dsLookupGlobal name
@@ -599,134 +584,30 @@ dsWhenNoErrs thing_inside mk_expr
                   then mk_expr result
                   else unitExpr }
 
---------------------------------------------------------------------------
---                  Data Parallel Haskell
---------------------------------------------------------------------------
-
--- | Run a 'DsM' with DPH things in scope if necessary.
-initDPH :: DsM a -> DsM a
-initDPH = loadDAP . initDPHBuiltins
-
--- | Extend the global environment with a 'GlobalRdrEnv' containing the exported
--- entities of,
+-- | Inject a trace message into the compiled program. Whereas
+-- pprTrace prints out information *while compiling*, pprRuntimeTrace
+-- captures that information and causes it to be printed *at runtime*
+-- using Debug.Trace.trace.
 --
---   * 'Data.Array.Parallel'      iff '-XParallelArrays' specified (see also 'checkLoadDAP').
---   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
-loadDAP :: DsM a -> DsM a
-loadDAP thing_inside
-  = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
-       ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
-       ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
-       }
-  where
-    loadOneModule :: ModuleName           -- the module to load
-                  -> DsM Bool             -- under which condition
-                  -> MsgDoc               -- error message if module not found
-                  -> DsM GlobalRdrEnv     -- empty if condition 'False'
-    loadOneModule modname check err
-      = do { doLoad <- check
-           ; if not doLoad
-             then return emptyGlobalRdrEnv
-             else do {
-           ; hsc_env <- getTopEnv
-           ; result <- liftIO $ findImportedModule hsc_env modname Nothing
-           ; case result of
-               Found _ mod -> dsLoadModule err mod
-               _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
-           } }
-
-    paErr       = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
-    veErr       = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
-    specBackend = text "you must specify a DPH backend package"
-    hint1       = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
-    hint2       = text "You may need to install them with 'cabal install dph-examples'"
-
--- | If '-XParallelArrays' given, we populate the builtin table for desugaring
--- those.
-initDPHBuiltins :: DsM a -> DsM a
-initDPHBuiltins thing_inside
-  = do { doInitBuiltins <- checkLoadDAP
-       ; if doInitBuiltins
-         then dsInitPArrBuiltin thing_inside
-         else thing_inside
-       }
-
-checkLoadDAP :: DsM Bool
-checkLoadDAP
-  = do { paEnabled <- xoptM LangExt.ParallelArrays
-       ; mod <- getModule
-         -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
-         -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
-         -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
-       ; return $ paEnabled &&
-                  mod /= gHC_PARR' &&
-                  moduleName mod /= dATA_ARRAY_PARALLEL_NAME
-       }
-
--- | Populate 'ds_parr_bi' from 'ds_dph_env'.
+--   pprRuntimeTrace hdr doc expr
 --
-dsInitPArrBuiltin :: DsM a -> DsM a
-dsInitPArrBuiltin thing_inside
-  = do { lengthPVar         <- externalVar (fsLit "lengthP")
-       ; replicatePVar      <- externalVar (fsLit "replicateP")
-       ; singletonPVar      <- externalVar (fsLit "singletonP")
-       ; mapPVar            <- externalVar (fsLit "mapP")
-       ; filterPVar         <- externalVar (fsLit "filterP")
-       ; zipPVar            <- externalVar (fsLit "zipP")
-       ; crossMapPVar       <- externalVar (fsLit "crossMapP")
-       ; indexPVar          <- externalVar (fsLit "!:")
-       ; emptyPVar          <- externalVar (fsLit "emptyP")
-       ; appPVar            <- externalVar (fsLit "+:+")
-       -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")
-       -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
-       ; enumFromToPVar     <- return arithErr
-       ; enumFromThenToPVar <- return arithErr
-
-       ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
-                                              { lengthPVar         = lengthPVar
-                                              , replicatePVar      = replicatePVar
-                                              , singletonPVar      = singletonPVar
-                                              , mapPVar            = mapPVar
-                                              , filterPVar         = filterPVar
-                                              , zipPVar            = zipPVar
-                                              , crossMapPVar       = crossMapPVar
-                                              , indexPVar          = indexPVar
-                                              , emptyPVar          = emptyPVar
-                                              , appPVar            = appPVar
-                                              , enumFromToPVar     = enumFromToPVar
-                                              , enumFromThenToPVar = enumFromThenToPVar
-                                              } })
-                   thing_inside
-       }
-  where
-    externalVar :: FastString -> DsM Var
-    externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
-
-    arithErr = panic "Arithmetic sequences have to wait until we support type classes"
-
--- |Get a name from "Data.Array.Parallel" for the desugarer, from the
--- 'ds_parr_bi' component of the global desugerar environment.
+-- will produce an expression that looks like
 --
-dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
-dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
-
--- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
---  Panic if there isn't one, or if it is defined multiple times.
-dsLookupDPHRdrEnv :: OccName -> DsM Name
-dsLookupDPHRdrEnv occ
-  = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
-  $ dsLookupDPHRdrEnv_maybe occ
-  where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
-
--- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
---  returning `Nothing` if it's not defined. Panic if it's defined multiple times.
-dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
-dsLookupDPHRdrEnv_maybe occ
-  = do { env <- ds_dph_env <$> getGblEnv
-       ; let gres = lookupGlobalRdrEnv env occ
-       ; case gres of
-           []    -> return $ Nothing
-           [gre] -> return $ Just $ gre_name gre
-           _     -> pprPanic multipleNames (ppr occ)
-       }
-  where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
+--   trace (hdr + doc) expr
+--
+-- When using this to debug a module that Debug.Trace depends on,
+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
+-- but that doesn't seem worth the effort and maintenance cost.
+pprRuntimeTrace :: String   -- ^ header
+                -> SDoc     -- ^ information to output
+                -> CoreExpr -- ^ expression
+                -> DsM CoreExpr
+pprRuntimeTrace str doc expr = do
+  traceId <- dsLookupGlobalId traceName
+  unpackCStringId <- dsLookupGlobalId unpackCStringName
+  dflags <- getDynFlags
+  let message :: CoreExpr
+      message = App (Var unpackCStringId) $
+                Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc)
+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
index 8158a8e122..58c31eee44 100644
--- a/compiler/deSugar/DsUsage.hs
+++ b/compiler/deSugar/DsUsage.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
 
 module DsUsage (
     -- * Dependency/fingerprinting code (used by MkIface)
@@ -7,6 +8,8 @@ module DsUsage (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import HscTypes
 import TcRnTypes
@@ -19,26 +22,54 @@ import UniqSet
 import UniqFM
 import Fingerprint
 import Maybes
+import Packages
+import Finder
 
+import Control.Monad (filterM)
 import Data.List
 import Data.IORef
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import System.Directory
+import System.FilePath
+
+{- Note [Module self-dependency]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+RnNames.calculateAvails asserts the invariant that a module must not occur in
+its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
+in the presence of hs-boot files: Consider that we have two modules, A and B,
+both with hs-boot files,
+
+    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
+    A.hs-boot declares an orphan instance A.hs defines the orphan instance
+
+In this case, B's dep_orphs will contain A due to its SOURCE import of A.
+Consequently, A will contain itself in its imp_orphs due to its import of B.
+This fact would end up being recorded in A's interface file. This would then
+break the invariant asserted by calculateAvails that a module does not itself in
+its dep_orphs. This was the cause of Trac #14128.
+
+-}
 
 -- | Extract information from the rename and typecheck phases to produce
 -- a dependencies information for the module being compiled.
-mkDependencies :: TcGblEnv -> IO Dependencies
-mkDependencies
-          TcGblEnv{ tcg_mod = mod,
+--
+-- The first argument is additional dependencies from plugins
+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
+mkDependencies iuid pluginModules
+          (TcGblEnv{ tcg_mod = mod,
                     tcg_imports = imports,
                     tcg_th_used = th_var
-                  }
+                  })
  = do
       -- Template Haskell used?
+      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
+          plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
       th_used <- readIORef th_var
       let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
-                                           (moduleName mod))
+                                             (moduleName mod))
                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
                 -- it before recording the modules on which this one depends!
                 -- (We want to retain M.hi-boot in imp_dep_mods so that
@@ -46,8 +77,14 @@ mkDependencies
                 --  on M.hi-boot, and hence that we should do the hi-boot consistency
                 --  check.)
 
-          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
-               | otherwise = imp_dep_pkgs imports
+          dep_orphs = filter (/= mod) (imp_orphs imports)
+                -- We must also remove self-references from imp_orphs. See
+                -- Note [Module self-dependency]
+
+          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
+
+          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
+               | otherwise = raw_pkgs
 
           -- Set the packages required to be Safe according to Safe Haskell.
           -- See Note [RnNames . Tracking Trust Transitively]
@@ -57,7 +94,8 @@ mkDependencies
 
       return Deps { dep_mods   = dep_mods,
                     dep_pkgs   = dep_pkgs',
-                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
+                    dep_orphs  = dep_orphs,
+                    dep_plgins = dep_plgins,
                     dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
                     -- sort to get into canonical order
                     -- NB. remember to use lexicographic ordering
@@ -65,11 +103,14 @@ mkDependencies
 mkUsedNames :: TcGblEnv -> NameSet
 mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
 
-mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage]
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
+            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]
 mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
+  pluginModules
   = do
     eps <- hscEPS hsc_env
     hashes <- mapM getFileHash dependent_files
+    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
     let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
                                        dir_imp_mods used_names
         usages = mod_usages ++ [ UsageFile { usg_file_path = f
@@ -80,11 +121,120 @@ mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
                                       usg_mod_hash = hash
                                     }
                                | (mod, hash) <- merged ]
+                            ++ concat plugin_usages
     usages `seqList` return usages
     -- seq the list of Usages returned: occasionally these
     -- don't get evaluated for a while and we can end up hanging on to
     -- the entire collection of Ifaces.
 
+{- Note [Plugin dependencies]
+Modules for which plugins were used in the compilation process, should be
+recompiled whenever one of those plugins changes. But how do we know if a
+plugin changed from the previous time a module was compiled?
+
+We could try storing the fingerprints of the interface files of plugins in
+the interface file of the module. And see if there are changes between
+compilation runs. However, this is pretty much a non-option because interface
+fingerprints of plugin modules are fairly stable, unless you compile plugins
+with optimisations turned on, and give basically all binders an INLINE pragma.
+
+So instead:
+
+  * For plugins that were build locally: we store the filepath and hash of the
+    object files of the module with the `plugin` binder, and the object files of
+    modules that are dependencies of the plugin module and belong to the same
+    `UnitId` as the plugin
+  * For plugins in an external package: we store the filepath and hash of
+    the dynamic library containing the plugin module.
+
+During recompilation we then compare the hashes of those files again to see
+if anything has changed.
+
+One issue with this approach is that object files are currently (GHC 8.6.1)
+not created fully deterministicly, which could sometimes induce accidental
+recompilation of a module for which plugins were used in the compile process.
+
+One way to improve this is to either:
+
+  * Have deterministic object file creation
+  * Create and store implementation hashes, which would be based on the Core
+    of the module and the implementation hashes of its dependencies, and then
+    compare implementation hashes for recompilation. Creation of implementation
+    hashes is however potentially expensive.
+-}
+mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
+mkPluginUsage hsc_env pluginModule
+  = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
+    -- The plug is from an external package, we just look up the dylib that
+    -- contains the plugin
+    LookupFound _ pkg -> do
+      let searchPaths = collectLibraryPaths dflags [pkg]
+          libs        = packageHsLibs dflags pkg
+          dynlibLocs  = [ searchPath </> mkHsSOName platform lib
+                        | searchPath <- searchPaths
+                        , lib <- libs
+                        ]
+      dynlibs <- filterM doesFileExist dynlibLocs
+      case dynlibs of
+        [] -> pprPanic
+                ("mkPluginUsage: no dylibs, tried:\n" ++ unlines dynlibLocs)
+                (ppr pNm)
+        _  -> mapM hashFile (nub dynlibs)
+    _ -> do
+      foundM <- findPluginModule hsc_env pNm
+      case foundM of
+        -- The plugin was built locally, look up the object file containing
+        -- the `plugin` binder, and all object files belong to modules that are
+        -- transitive dependencies of the plugin that belong to the same package
+        Found ml _ -> do
+          pluginObject <- hashFile  (ml_obj_file ml)
+          depObjects   <- catMaybes <$> mapM lookupObjectFile deps
+          return (nub (pluginObject : depObjects))
+        _ -> pprPanic "mkPluginUsage: no object or dylib" (ppr pNm)
+  where
+    -- plugins are shared libraries, so WayDyn should be part of the dflags in
+    -- order to get the correct filenames and library paths.
+    --
+    -- We can distinguish two scenarios:
+    --
+    -- 1. The dflags do not contain WayDyn, in this case we need to remove
+    --    all other ways and only add WayDyn. Why? Because other ways change
+    --    the library tags, i.e. WayProf adds `_p`, and we would end up looking
+    --    for a profiled plugin which might not be installed. See #15492
+    --
+    -- 2. The dflags do contain WayDyn, in this case we can leave the ways as
+    --    is, because the plugin must be compiled with the same ways as the
+    --    module that is currently being build, e.g., if the module is
+    --    build with WayDyn and WayProf, then the plugin that was used
+    --    would've also had to been build with WayProf (and WayDyn).
+    dflags1  = hsc_dflags hsc_env
+    dflags   = if WayDyn `elem` ways dflags1
+                 then dflags1
+                 else updateWays (addWay' WayDyn (dflags1 {ways = []}))
+    platform = targetPlatform dflags
+    pNm      = moduleName (mi_module pluginModule)
+    pPkg     = moduleUnitId (mi_module pluginModule)
+    deps     = map fst (dep_mods (mi_deps pluginModule))
+
+    -- loopup object file for a plugin dependencies from the same package as the
+    -- the plugin
+    lookupObjectFile nm = do
+      foundM <- findImportedModule hsc_env nm Nothing
+      case foundM of
+        Found ml m
+          | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)
+          | otherwise              -> return Nothing
+        _ -> pprPanic "mkPluginUsage: no object for dependency"
+                      (ppr pNm <+> ppr nm)
+
+    hashFile f = do
+      fExist <- doesFileExist f
+      if fExist
+         then do
+            h <- getFileHash f
+            return (UsageFile f h)
+         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)
+
 mk_mod_usage_info :: PackageIfaceTable
               -> HscEnv
               -> Module
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index a1f3a143f3..001b36151c 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
@@ -35,11 +37,14 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} Match  ( matchSimply )
 import {-# SOURCE #-} DsExpr ( dsLExpr )
 
@@ -93,6 +98,7 @@ otherwise, make one up.
 -}
 
 selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 
 -- (selectMatchVars ps tys) chooses variables of type tys
@@ -112,21 +118,22 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
 
 selectMatchVars :: [Pat GhcTc] -> DsM [Id]
+-- Postcondition: the returned Ids have Internal Names
 selectMatchVars ps = mapM selectMatchVar ps
 
 selectMatchVar :: Pat GhcTc -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
+-- Postcondition: the returned Id has an Internal Name
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
                                   -- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
                                   -- OK, better make up one...
 
-{-
-Note [Localise pattern binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider     module M where
                [Just a] = e
 After renaming it looks like
@@ -162,6 +169,7 @@ In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
 runs on the output of the desugarer, so all is well by the end of
 the desugaring pass.
 
+See also Note [MatchIds] in Match.hs
 
 ************************************************************************
 *                                                                      *
@@ -278,18 +286,15 @@ data CaseAlt a = MkCaseAlt{ alt_pat :: a,
                             alt_result :: MatchResult }
 
 mkCoAlgCaseMatchResult
-  :: DynFlags
-  -> Id                 -- Scrutinee
+  :: Id                 -- Scrutinee
   -> Type               -- Type of exp
   -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
   -> MatchResult
-mkCoAlgCaseMatchResult dflags var ty match_alts
+mkCoAlgCaseMatchResult var ty match_alts
   | isNewtype  -- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 
-  | isPArrFakeAlts match_alts
-  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)
   | otherwise
   = mkDataConCase var ty match_alts
   where
@@ -307,34 +312,6 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
                                                 -- (not that splitTyConApp does, these days)
     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
 
-        --- Stuff for parallel arrays
-        --
-        -- Concerning `isPArrFakeAlts':
-        --
-        --  * it is *not* sufficient to just check the type of the type
-        --   constructor, as we have to be careful not to confuse the real
-        --   representation of parallel arrays with the fake constructors;
-        --   moreover, a list of alternatives must not mix fake and real
-        --   constructors (this is checked earlier on)
-        --
-        -- FIXME: We actually go through the whole list and make sure that
-        --        either all or none of the constructors are fake parallel
-        --        array constructors.  This is to spot equations that mix fake
-        --        constructors with the real representation defined in
-        --        `PrelPArr'.  It would be nicer to spot this situation
-        --        earlier and raise a proper error message, but it can really
-        --        only happen in `PrelPArr' anyway.
-        --
-
-    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
-    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
-    isPArrFakeAlts (alt:alts) =
-      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of
-        (True , True ) -> True
-        (False, False) -> False
-        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
-    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
-
 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
 mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
 
@@ -344,7 +321,7 @@ sort_alts = sortWith (dataConTag . alt_pat)
 mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
 mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $
-                         nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty]
+                         nlHsTyApp matcher [getRuntimeRep ty, ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
     return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
@@ -408,49 +385,6 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
         = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 
---- Stuff for parallel arrays
---
---  * the following is to desugar cases over fake constructors for
---   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
---   case
---
-mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr
-           -> DsM CoreExpr
-mkPArrCase dflags var ty sorted_alts fail = do
-    lengthP <- dsDPHBuiltin lengthPVar
-    alt <- unboxAlt
-    return (mkWildCase (len lengthP) intTy ty [alt])
-  where
-    elemTy      = case splitTyConApp (idType var) of
-        (_, [elemTy]) -> elemTy
-        _             -> panic panicMsg
-    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
-    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
-    --
-    unboxAlt = do
-        l      <- newSysLocalDs intPrimTy
-        indexP <- dsDPHBuiltin indexPVar
-        alts   <- mapM (mkAlt indexP) sorted_alts
-        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
-      where
-        dft  = (DEFAULT, [], fail)
-
-    --
-    -- each alternative matches one array length (corresponding to one
-    -- fake array constructor), so the match is on a literal; each
-    -- alternative's body is extended by a local binding for each
-    -- constructor argument, which are bound to array elements starting
-    -- with the first
-    --
-    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
-        body <- bodyFun fail
-        return (LitAlt lit, [], mkCoreLets binds body)
-      where
-        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
-        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
-        --
-        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
-
 {-
 ************************************************************************
 *                                                                      *
@@ -471,7 +405,7 @@ mkErrorAppDs err_id ty msg = do
         full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
         core_msg = Lit (mkMachString full_msg)
         -- mkMachString returns a result of type String#
-    return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])
+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
 
 {-
 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
@@ -556,7 +490,7 @@ mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
 
 -- NB: No argument can be levity polymorphic
 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
+mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
 
 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
 -- We define a desugarer-specific version of CoreUtils.mkCast,
@@ -734,7 +668,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
                 -- and all the desugared binds
 
 mkSelectorBinds ticks pat val_expr
-  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)
+  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
   = return (v, [(v, val_expr)])
 
   | is_flat_prod_lpat pat'           -- Special case (B)
@@ -758,7 +692,7 @@ mkSelectorBinds ticks pat val_expr
 
   | otherwise                          -- General case (C)
   = do { tuple_var  <- newSysLocalDs tuple_ty
-       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat')
+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
        ; tuple_expr <- matchSimply val_expr PatBindRhs pat
                                    local_tuple error_expr
        ; let mk_tup_bind tick binder
@@ -781,17 +715,17 @@ mkSelectorBinds ticks pat val_expr
 
 strip_bangs :: LPat a -> LPat a
 -- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat p))  = strip_bangs p
-strip_bangs (L _ (BangPat p)) = strip_bangs p
-strip_bangs lp                = lp
+strip_bangs (L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                  = lp
 
 is_flat_prod_lpat :: LPat a -> Bool
 is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
 
 is_flat_prod_pat :: Pat a -> Bool
-is_flat_prod_pat (ParPat p)            = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = L _ pcon, pat_args = ps})
   | RealDataCon con <- pcon
   , isProductTyCon (dataConTyCon con)
   = all is_triv_lpat (hsConPatArgs ps)
@@ -801,10 +735,10 @@ is_triv_lpat :: LPat a -> Bool
 is_triv_lpat p = is_triv_pat (unLoc p)
 
 is_triv_pat :: Pat a -> Bool
-is_triv_pat (VarPat _)  = True
-is_triv_pat (WildPat _) = True
-is_triv_pat (ParPat p)  = is_triv_lpat p
-is_triv_pat _           = False
+is_triv_pat (VarPat {})  = True
+is_triv_pat (WildPat{})  = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _            = False
 
 
 {- *********************************************************************
@@ -826,7 +760,7 @@ mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 
 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
@@ -973,16 +907,41 @@ mkBinaryTickBox ixT ixF e = do
 
 -- *******************************************************************
 
+{- Note [decideBangHood]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With -XStrict we may make /outermost/ patterns more strict.
+E.g.
+       let (Just x) = e in ...
+          ==>
+       let !(Just x) = e in ...
+and
+       f x = e
+          ==>
+       f !x = e
+
+This adjustment is done by decideBangHood,
+
+  * Just before constructing an EqnInfo, in Match
+      (matchWrapper and matchSinglePat)
+
+  * When desugaring a pattern-binding in DsBinds.dsHsBind
+
+Note that it is /not/ done recursively.  See the -XStrict
+spec in the user manual.
+
+Specifically:
+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+   !pat    => !pat   -- always
+   pat     => !pat   -- when -XStrict
+   pat     => pat    -- otherwise
+-}
+
+
 -- | Use -XStrict to add a ! or remove a ~
---
--- Examples:
--- ~pat    => pat    -- when -XStrict (even if pat = ~pat')
--- !pat    => !pat   -- always
--- pat     => !pat   -- when -XStrict
--- pat     => pat    -- otherwise
+-- See Note [decideBangHood]
 decideBangHood :: DynFlags
-               -> LPat id  -- ^ Original pattern
-               -> LPat id  -- Pattern with bang if necessary
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
 decideBangHood dflags lpat
   | not (xopt LangExt.Strict dflags)
   = lpat
@@ -991,19 +950,49 @@ decideBangHood dflags lpat
   where
     go lp@(L l p)
       = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> lp'
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> lp'
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExt lp)
 
 -- | Unconditionally make a 'Pat' strict.
-addBang :: LPat id -- ^ Original pattern
-        -> LPat id -- ^ Banged pattern
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
 addBang = go
   where
     go lp@(L l p)
       = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> L l (BangPat lp')
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> L l (BangPat noExt lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExt lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
+                                      || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
+isTrueLHsExpr _                       = Nothing
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
new file mode 100644
index 0000000000..fc57f98569
--- /dev/null
+++ b/compiler/deSugar/ExtractDocs.hs
@@ -0,0 +1,344 @@
+-- | Extract docs from the renamer output so they can be be serialized.
+{-# language LambdaCase #-}
+{-# language TypeFamilies #-}
+module ExtractDocs (extractDocs) where
+
+import GhcPrelude
+import Bag
+import HsBinds
+import HsDoc
+import HsDecls
+import HsExtension
+import HsTypes
+import HsUtils
+import Name
+import NameSet
+import SrcLoc
+import TcRnTypes
+
+import Control.Applicative
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Semigroup
+
+-- | Extract docs from renamer output.
+extractDocs :: TcGblEnv
+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+            -- ^
+            -- 1. Module header
+            -- 2. Docs on top level declarations
+            -- 3. Docs on arguments
+extractDocs TcGblEnv { tcg_semantic_mod = mod
+                     , tcg_rn_decls = mb_rn_decls
+                     , tcg_insts = insts
+                     , tcg_fam_insts = fam_insts
+                     , tcg_doc_hdr = mb_doc_hdr
+                     } =
+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+  where
+    (doc_map, arg_map) = maybe (M.empty, M.empty)
+                               (mkMaps local_insts)
+                               mb_decls_with_docs
+    mb_decls_with_docs = topDecls <$> mb_rn_decls
+    local_insts = filter (nameIsLocalOrFrom mod)
+                         $ map getName insts ++ map getName fam_insts
+
+-- | Create decl and arg doc-maps by looping through the declarations.
+-- For each declaration, find its names, its subordinates, and its doc strings.
+mkMaps :: [Name]
+       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+mkMaps instances decls =
+    ( f' (map (nubByName fst) decls')
+    , f  (filterMapping (not . M.null) args)
+    )
+  where
+    (decls', args) = unzip (map mappings decls)
+
+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
+    f' = M.fromListWith appendDocs . concat
+
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
+    mappings :: (LHsDecl GhcRn, [HsDocString])
+             -> ( [(Name, HsDocString)]
+                , [(Name, Map Int (HsDocString))]
+                )
+    mappings (L l decl, docStrs) =
+           (dm, am)
+      where
+        doc = concatDocs docStrs
+        args = declTypeDocs decl
+
+        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs = subordinates instanceMap decl
+
+        (subDocs, subArgs) =
+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
+
+        ns = names l decl
+        subNs = [ n | (n, _, _) <- subs ]
+        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
+        am = [(n, args) | n <- ns] ++ zip subNs subArgs
+
+    instanceMap :: Map SrcSpan Name
+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+
+    names :: SrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
+                                                                 -- Note [1].
+      where loc = case d of
+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
+                                  -- for TFs
+              _ -> getInstLoc d
+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+    names _ decl = getMainDeclBinder decl
+
+{-
+Note [1]:
+---------
+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+inside them. That should work for normal user-written instances (from
+looking at GHC sources). We can assume that commented instances are
+user-written. This lets us relate Names (from ClsInsts) to comments
+(associated with InstDecls and DerivDecls).
+-}
+
+getMainDeclBinder :: HsDecl pass -> [IdP pass]
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _                             = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc = \case
+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+  DataFamInstD _ (DataFamInstDecl
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
+  TyFamInstD _ (TyFamInstDecl
+    -- Since CoAxioms' Names refer to the whole line for type family instances
+    -- in particular, we need to dig a bit deeper to pull out the entire
+    -- equation. This does not happen for data family instances, for some
+    -- reason.
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  XInstDecl _ -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
+subordinates :: Map SrcSpan Name
+             -> HsDecl GhcRn
+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+subordinates instMap decl = case decl of
+  InstD _ (ClsInstD _ d) -> do
+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+      FamEqn { feqn_tycon = L l _
+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+
+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+    -> dataSubs (feqn_rhs d)
+  TyClD _ d | isClassDecl d -> classSubs d
+            | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
+  where
+    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs :: HsDataDefn GhcRn
+             -> [(Name, [HsDocString], Map Int (HsDocString))]
+    dataSubs dd = constrs ++ fields ++ derivs
+      where
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ ( unLoc cname
+                    , maybeToList $ fmap unLoc $ con_doc c
+                    , conArgDocs c)
+                  | c <- cons, cname <- getConNames c ]
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+                  | RecCon flds <- map getConArgs cons
+                  , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
+                  , L _ n <- ns ]
+        derivs  = [ (instName, [unLoc doc], M.empty)
+                  | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
+                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $
+                           unLoc $ dd_derivs dd
+                  , Just instName <- [M.lookup l instMap] ]
+
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
+conArgDocs con = case getConArgs con of
+                   PrefixCon args -> go 0 (map unLoc args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   RecCon _ -> go 1 ret
+  where
+    go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+    go n (_ : tys) = go (n+1) tys
+    go _ [] = M.empty
+
+    ret = case con of
+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+            _ -> []
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _ _) = True
+isValD _ = False
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+  where
+    decls = docs ++ defs ++ sigs ++ ats
+    docs  = mkDecls tcdDocs (DocD noExt) class_
+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+    sigs  = mkDecls tcdSigs (SigD noExt) class_
+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs = \case
+  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))
+  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))
+  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))
+  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))
+  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
+  _                                 -> M.empty
+
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go _ [] = []
+    go s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs = go 0
+  where
+    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
+    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) =
+       M.insert n x $ go (n+1) ty
+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
+    go _ _ = M.empty
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+ungroup group_ =
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ ++
+  mkDecls hs_derivds             (DerivD noExt) group_ ++
+  mkDecls hs_defds               (DefD noExt)   group_ ++
+  mkDecls hs_fords               (ForD noExt)   group_ ++
+  mkDecls hs_docs                (DocD noExt)   group_ ++
+  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ ++
+  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ ++
+  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_
+  where
+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
+    typesigs _ = error "expected ValBindsOut"
+
+    valbinds (XValBindsLR (NValBinds binds _)) =
+      concatMap bagToList . snd . unzip $ binds
+    valbinds _ = error "expected ValBindsOut"
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortOn getLoc
+
+-- | Collect docs and attach them to the right declarations.
+--
+-- A declaration may have multiple doc strings attached to it.
+collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+-- ^ This is an example.
+collectDocs = go Nothing []
+  where
+    go Nothing _ [] = []
+    go (Just prev) docs [] = finished prev docs []
+    go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
+      | Nothing <- prev = go Nothing (str:docs) ds
+      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+    go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) =
+      go prev (str:docs) ds
+    go Nothing docs (d:ds) = go (Just d) docs ds
+    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+
+    finished decl docs rest = (decl, reverse docs) : rest
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unLoc . fst)
+  where
+    isHandled (ForD _ (ForeignImport {})) = True
+    isHandled (TyClD {})  = True
+    isHandled (InstD {})  = True
+    isHandled (DerivD {}) = True
+    isHandled (SigD _ d)  = isUserSig d
+    isHandled (ValD {})   = True
+    -- we keep doc declarations to be able to get at named docs
+    isHandled (DocD {})   = True
+    isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
+                      | x@(L loc d, doc) <- decls ]
+  where
+    filterClass (TyClD x c) =
+      TyClD x $ c { tcdSigs =
+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+    filterClass _ = error "expected TyClD"
+
+-- | Was this signature given by the user?
+isUserSig :: Sig name -> Bool
+isUserSig TypeSig {}    = True
+isUserSig ClassOpSig {} = True
+isUserSig PatSynSig {}  = True
+isUserSig _             = False
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD _ d) = isClassDecl d
+isClassD _ = False
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index a870c6f9c3..ec982f6b25 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -9,10 +9,13 @@ The @match@ function
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply
+             , matchSinglePat, matchSinglePatVar ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
 
 import DynFlags
@@ -37,7 +40,6 @@ import MatchCon
 import MatchLit
 import Type
 import Coercion ( eqCoercion )
-import TcType ( toTcTypeBag )
 import TyCon( isNewTyCon )
 import TysWiredIn
 import SrcLoc
@@ -51,8 +53,8 @@ import Unique
 import UniqDFM
 
 import Control.Monad( when, unless )
+import Data.List ( groupBy )
 import qualified Data.Map as Map
-import Data.List (groupBy)
 
 {-
 ************************************************************************
@@ -61,7 +63,8 @@ import Data.List (groupBy)
 *                                                                      *
 ************************************************************************
 
-The function @match@ is basically the same as in the Wadler chapter,
+The function @match@ is basically the same as in the Wadler chapter
+from "The Implementation of Functional Programming Languages",
 except it is monadised, to carry around the name supply, info about
 annotations, etc.
 
@@ -123,40 +126,25 @@ patterns that is examined.  The steps carried out are roughly:
 \item
 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
 bindings to the second component of the equation-info):
-\begin{itemize}
-\item
-Remove the `as' patterns from column~1.
-\item
-Make all constructor patterns in column~1 into @ConPats@, notably
-@ListPats@ and @TuplePats@.
-\item
-Handle any irrefutable (or ``twiddle'') @LazyPats@.
-\end{itemize}
 \item
 Now {\em unmix} the equations into {\em blocks} [w\/ local function
-@unmix_eqns@], in which the equations in a block all have variable
-patterns in column~1, or they all have constructor patterns in ...
+@match_groups@], in which the equations in a block all have the same
+ match group.
 (see ``the mixture rule'' in SLPJ).
 \item
-Call @matchEqnBlock@ on each block of equations; it will do the
-appropriate thing for each kind of column-1 pattern, usually ending up
-in a recursive call to @match@.
+Call the right match variant on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern.
 \end{enumerate}
 
 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 And gluing the ``success expressions'' together isn't quite so pretty.
 
-This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
-(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
-(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+This  @match@ uses @tidyEqnInfo@
+to get `as'- and `twiddle'-patterns out of the way (tidying), before
+applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
 un}mixes the equations], producing a list of equation-info
-blocks, each block having as its first column of patterns either all
-constructors, or all variables (or similar beasts), etc.
-
-@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
-Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
-corresponds roughly to @matchVarCon@.
+blocks, each block having as its first column patterns compatible with each other.
 
 Note [Match Ids]
 ~~~~~~~~~~~~~~~~
@@ -165,6 +153,8 @@ is the scrutinee(s) of the match. The desugared expression may
 sometimes use that Id in a local binding or as a case binder.  So it
 should not have an External name; Lint rejects non-top-level binders
 with External names (Trac #13043).
+
+See also Note [Localise pattern binders] in DsUtils
 -}
 
 type MatchId = Id   -- See Note [Match Ids]
@@ -263,7 +253,7 @@ matchBangs [] _ _ = panic "matchBangs"
 matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
-  = do  { let CoPat co pat _ = firstPat eqn1
+  = do  { let CoPat _ co pat _ = firstPat eqn1
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
         ; match_result <- match (var':vars) ty $
@@ -279,7 +269,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
   = do  { -- we could pass in the expr from the PgView,
          -- but this needs to extract the pat anyway
          -- to figure out the type of the fresh variable
-         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
@@ -296,7 +286,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
 -- Since overloaded list patterns are treated as view patterns,
 -- the code is roughly the same as for matchView
-  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
        ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
        ; match_result <- match (var':vars) ty $
                             map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
@@ -311,13 +301,14 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
 decomposeFirstPat _ _ = panic "decomposeFirstPat"
 
 getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (CoPat _ pat _)     = pat
+getCoPat (CoPat _ _ pat _)   = pat
 getCoPat _                   = panic "getCoPat"
-getBangPat (BangPat pat  )   = unLoc pat
+getBangPat (BangPat _ pat  ) = unLoc pat
 getBangPat _                 = panic "getBangPat"
-getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat (ViewPat _ _ pat) = unLoc pat
 getViewPat _                 = panic "getViewPat"
-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+        = ListPat (ListPatTc ty Nothing)  pats
 getOLPat _                   = panic "getOLPat"
 
 {-
@@ -346,39 +337,40 @@ See also Note [Case elimination: lifted case] in Simplify.
 ************************************************************************
 
 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-which will be scrutinised.  This means:
-\begin{itemize}
-\item
-Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
-together with the binding @x = v@.
-\item
-Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
-\item
-Removing lazy (irrefutable) patterns (you don't want to know...).
-\item
-Converting explicit tuple-, list-, and parallel-array-pats into ordinary
-@ConPats@.
-\item
-Convert the literal pat "" to [].
-\end{itemize}
+which will be scrutinised.
 
-The result of this tidying is that the column of patterns will include
-{\em only}:
-\begin{description}
-\item[@WildPats@:]
-The @VarPat@ information isn't needed any more after this.
+This makes desugaring the pattern match simpler by transforming some of
+the patterns to simpler forms. (Tuples to Constructor Patterns)
 
-\item[@ConPats@:]
-@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
+Among other things in the resulting Pattern:
+* Variables and irrefutable(lazy) patterns are replaced by Wildcards
+* As patterns are replaced by the patterns they wrap.
+
+The bindings created by the above patterns are put into the returned wrapper
+instead.
+
+This means a definition of the form:
+  f x = rhs
+when called with v get's desugared to the equivalent of:
+  let x = v
+  in
+  f _ = rhs
+
+The same principle holds for as patterns (@) and
+irrefutable/lazy patterns (~).
+In the case of irrefutable patterns the irrefutable pattern is pushed into
+the binding.
+
+Pattern Constructors which only represent syntactic sugar are converted into
+their desugared representation.
+This usually means converting them to Constructor patterns but for some
+depends on enabled extensions. (Eg OverloadedLists)
+
+GHC also tries to convert overloaded Literals into regular ones.
+
+The result of this tidying is that the column of patterns will include
+only these which can be assigned a PatternGroup (see patGroup).
 
-\item[@LitPats@ and @NPats@:]
-@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
-Float,  Double, at least) are converted to unboxed form; e.g.,
-\tr{(NPat (HsInt i) _ _)} is converted to:
-\begin{verbatim}
-(ConPat I# _ _ [LitPat (HsIntPrim i)])
-\end{verbatim}
-\end{description}
 -}
 
 tidyEqnInfo :: Id -> EquationInfo
@@ -389,12 +381,7 @@ tidyEqnInfo :: Id -> EquationInfo
         -- one pattern and fiddling the list of bindings.
         --
         -- POST CONDITION: head pattern in the EqnInfo is
-        --      WildPat
-        --      ConPat
-        --      NPat
-        --      LitPat
-        --      NPlusKPat
-        -- but no other
+        --      one of these for which patGroup is defined.
 
 tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
   = panic "tidyEqnInfo"
@@ -412,26 +399,21 @@ tidy1 :: Id                  -- The Id being scrutinised
 --      (pat', mr') = tidy1 v pat mr
 -- tidies the *outer level only* of pat, giving pat'
 -- It eliminates many pattern forms (as-patterns, variable patterns,
--- list patterns, etc) yielding one of:
---      WildPat
---      ConPatOut
---      LitPat
---      NPat
---      NPlusKPat
-
-tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
+-- list patterns, etc) and returns any created bindings in the wrapper.
+
+tidy1 v (ParPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat (L _ var))
+tidy1 v (VarPat _ (L _ var))
   = return (wrapBind var v, WildPat (idType var))
 
         -- case v of { x@p -> mr[] }
         -- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat)
+tidy1 v (AsPat _ (L _ var) pat)
   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
         ; return (wrapBind var v . wrap, pat') }
 
@@ -446,7 +428,7 @@ tidy1 v (AsPat (L _ var) pat)
     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 -}
 
-tidy1 v (LazyPat pat)
+tidy1 v (LazyPat _ pat)
     -- This is a convenient place to check for unlifted types under a lazy pattern.
     -- Doing this check during type-checking is unsatisfactory because we may
     -- not fully know the zonked types yet. We sure do here.
@@ -462,39 +444,31 @@ tidy1 v (LazyPat pat)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 _ (ListPat pats ty Nothing)
+tidy1 _ (ListPat (ListPatTc ty Nothing) pats )
   = return (idDsWrapper, unLoc list_ConPat)
   where
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                         (mkNilPat ty)
                         pats
 
--- Introduce fake parallel array constructors to be able to handle parallel
--- arrays with the existing machinery for constructor pattern
-tidy1 _ (PArrPat pats ty)
-  = return (idDsWrapper, unLoc parrConPat)
-  where
-    arity      = length pats
-    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-
-tidy1 _ (TuplePat pats boxity tys)
+tidy1 _ (TuplePat tys pats boxity)
   = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
     tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
 
-tidy1 _ (SumPat pat alt arity tys)
+tidy1 _ (SumPat tys pat alt arity)
   = return (idDsWrapper, unLoc sum_ConPat)
   where
     sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (LitPat lit)
+tidy1 _ (LitPat _ lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat (L _ lit) mb_neg eq ty)
-  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
+tidy1 _ (NPat ty (L _ lit) mb_neg eq)
+  = return (idDsWrapper, tidyNPat lit mb_neg eq ty)
 
 -- Everything else goes through unchanged...
 
@@ -505,20 +479,20 @@ tidy1 _ non_interesting_pat
 tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
-tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
+tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
-tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
+tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
+tidy_bang_pat v l (CoPat x w p t)
+  = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
 
 -- Discard bang around strict pattern
 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
 tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
 tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
 tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
-tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
 
 -- Data/newtype constructors
 tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
@@ -547,7 +521,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
 --
 -- NB: SigPatIn, ConPatIn should not happen
 
-tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
 
 -------------------
 push_bang_into_newtype_arg :: SrcSpan
@@ -558,15 +532,16 @@ push_bang_into_newtype_arg :: SrcSpan
 -- We are transforming   !(N p)   into   (N !p)
 push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
   = ASSERT( null args)
-    PrefixCon [L l (BangPat arg)]
+    PrefixCon [L l (BangPat noExt arg)]
 push_bang_into_newtype_arg l _ty (RecCon rf)
   | HsRecFields { rec_flds = L lf fld : flds } <- rf
   , HsRecField { hsRecFieldArg = arg } <- fld
   = ASSERT( null flds)
-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+                                           = L l (BangPat noExt arg) })] })
 push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
   | HsRecFields { rec_flds = [] } <- rf
-  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+  = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
 push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
@@ -726,8 +701,7 @@ JJQC 30-Nov-1997
 -}
 
 matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
-                             , mg_arg_tys = arg_tys
-                             , mg_res_ty = rhs_ty
+                             , mg_ext = MatchGroupTc arg_tys rhs_ty
                              , mg_origin = origin })
   = do  { dflags <- getDynFlags
         ; locn   <- getSrcSpanDs
@@ -749,25 +723,21 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info vars (L _ (Match ctx pats _ grhss))
+    mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
       = do { dflags <- getDynFlags
-           ; let add_bang
-                   | FunRhs {mc_strictness=SrcStrict} <- ctx
-                   = pprTrace "addBang" empty addBang
-                   | otherwise
-                   = decideBangHood dflags
-                 upats = map (unLoc . add_bang) pats
-                 dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
+           ; let upats = map (unLoc . decideBangHood dflags) pats
+                 dicts = collectEvVarsPats upats
            ; tm_cs <- genCaseTmCs2 mb_scr upats vars
            ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
                              addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
                              dsGRHSs ctxt grhss rhs_ty
-           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
+           ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
+    mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper"
 
     handleWarnings = if isGenerated origin
                      then discardWarningsDs
                      else id
-
+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
 
 matchEquations  :: HsMatchContext Name
                 -> [MatchId] -> [EquationInfo] -> Type
@@ -810,7 +780,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
                -> Type -> MatchResult -> DsM MatchResult
 -- matchSinglePat ensures that the scrutinee is a variable
--- and then calls match_single_pat_var
+-- and then calls matchSinglePatVar
 --
 -- matchSinglePat does not warn about incomplete patterns
 -- Used for things like [ e | pat <- stuff ], where
@@ -818,17 +788,17 @@ matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
 
 matchSinglePat (Var var) ctx pat ty match_result
   | not (isExternalName (idName var))
-  = match_single_pat_var var ctx pat ty match_result
+  = matchSinglePatVar var ctx pat ty match_result
 
 matchSinglePat scrut hs_ctx pat ty match_result
   = do { var           <- selectSimpleMatchVarL pat
-       ; match_result' <- match_single_pat_var var hs_ctx pat ty match_result
+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
-match_single_pat_var :: Id   -- See Note [Match Ids]
-                     -> HsMatchContext Name -> LPat GhcTc
-                     -> Type -> MatchResult -> DsM MatchResult
-match_single_pat_var var ctx pat ty match_result
+matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> HsMatchContext Name -> LPat GhcTc
+                  -> Type -> MatchResult -> DsM MatchResult
+matchSinglePatVar var ctx pat ty match_result
   = ASSERT2( isInternalName (idName var), ppr var )
     do { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs
@@ -910,7 +880,7 @@ subGroup :: (m -> [[EquationInfo]]) -- Map.elems
 -- Parameterized by map operations to allow different implementations
 -- and constraints, eg. types without Ord instance.
 subGroup elems empty lookup insert group
-    = map reverse $ elems $ foldl accumulate empty group
+    = map reverse $ elems $ foldl' accumulate empty group
   where
     accumulate pg_map (pg, eqn)
       = case lookup pg pg_map of
@@ -1001,18 +971,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
     -- real comparison is on HsExpr's
     -- strip parens
-    exp (HsPar (L _ e)) e'   = exp e e'
-    exp e (HsPar (L _ e'))   = exp e e'
+    exp (HsPar _ (L _ e)) e'   = exp e e'
+    exp e (HsPar _ (L _ e'))   = exp e e'
     -- because the expressions do not necessarily have the same type,
     -- we have to compare the wrappers
-    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
-    exp (HsVar i) (HsVar i') =  i == i'
-    exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
     -- the instance for IPName derives using the id, so this works if the
     -- above does
-    exp (HsIPVar i) (HsIPVar i') = i == i'
-    exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
-    exp (HsOverLit l) (HsOverLit l') =
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
         -- Overloaded lits are equal if they have the same type
         -- and the data is the same.
         -- this is coarser than comparing the SyntaxExpr's in l and l',
@@ -1020,20 +990,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         -- because these expressions get written as a bunch of different variables
         -- (presumably to improve sharing)
         eqType (overLitType l) (overLitType l') && l == l'
-    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
-    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
         lexp l l' && lexp o o' && lexp ri ri'
-    exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
-    exp (SectionL e1 e2) (SectionL e1' e2') =
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (SectionR e1 e2) (SectionR e1' e2') =
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
         eq_list tup_arg es1 es2
-    exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
         lexp e e' && lexp e1 e1' && lexp e2 e2'
 
     -- Enhancement: could implement equality for more expressions
@@ -1055,8 +1025,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         wrap res_wrap1 res_wrap2
 
     ---------
-    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
-    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -1079,8 +1049,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
 
     ---------
     ev_term :: EvTerm -> EvTerm -> Bool
-    ev_term (EvId a)       (EvId b)       = a==b
-    ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b
+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b
+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
     ev_term _ _ = False
 
     ---------
@@ -1097,7 +1067,7 @@ patGroup _ (ConPatOut { pat_con = L _ con
  | PatSynCon psyn <- con                = PgSyn psyn tys
 patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
-patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
+patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
   case (oval, isJust mb_neg) of
    (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
    (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
@@ -1105,14 +1075,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
    (HsFractional r, True ) -> PgN (-fl_value r)
    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
                           PgOverS s
-patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
+patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
   case oval of
    HsIntegral i -> PgNpK (il_value i)
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList
-patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
 patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
 
 {-
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
index 4096b9cd0b..e77ad548b6 100644
--- a/compiler/deSugar/Match.hs-boot
+++ b/compiler/deSugar/Match.hs-boot
@@ -1,4 +1,6 @@
 module Match where
+
+import GhcPrelude
 import Var      ( Id )
 import TcType   ( Type )
 import DsMonad  ( DsM, EquationInfo, MatchResult )
@@ -26,8 +28,8 @@ matchSimply
         -> CoreExpr
         -> DsM CoreExpr
 
-matchSinglePat
-        :: CoreExpr
+matchSinglePatVar
+        :: Id
         -> HsMatchContext Name
         -> LPat GhcTc
         -> Type
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
index 7923ae4eb5..af542340fa 100644
--- a/compiler/deSugar/MatchCon.hs
+++ b/compiler/deSugar/MatchCon.hs
@@ -13,6 +13,8 @@ module MatchCon ( matchConFamily, matchPatSyn ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} Match     ( match )
 
 import HsSyn
@@ -27,7 +29,6 @@ import Id
 import NameEnv
 import FieldLabel ( flSelector )
 import SrcLoc
-import DynFlags
 import Outputable
 import Control.Monad(liftM)
 import Data.List (groupBy)
@@ -91,9 +92,8 @@ matchConFamily :: [Id]
                -> DsM MatchResult
 -- Each group of eqns is for a single constructor
 matchConFamily (var:vars) ty groups
-  = do dflags <- getDynFlags
-       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
-       return (mkCoAlgCaseMatchResult dflags var ty alts)
+  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
+       return (mkCoAlgCaseMatchResult var ty alts)
   where
     toRealAlt alt = case alt_pat alt of
         RealDataCon dcon -> alt{ alt_pat = dcon }
@@ -120,7 +120,10 @@ matchOneConLike :: [Id]
                 -> [EquationInfo]
                 -> DsM (CaseAlt ConLike)
 matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
-  = do  { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
+  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
+                           -- ex_tvs can only be tyvars as data types in source
+                           -- Haskell cannot mention covar yet (Aug 2018).
+                         ASSERT( tvs1 `equalLength` ex_tvs )
                          arg_tys ++ mkTyVarTys tvs1
 
               val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
@@ -169,7 +172,7 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
               = firstPat eqn1
     fields1 = map flSelector (conLikeFieldLabels con1)
 
-    ex_tvs = conLikeExTyVars con1
+    ex_tvs = conLikeExTyCoVars con1
 
     -- Choose the right arg_vars in the right order for this group
     -- Note [Record patterns]
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index c3ba420232..ca7ef0af2f 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -17,6 +17,8 @@ module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} Match  ( match )
 import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
 
@@ -75,30 +77,32 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
 -}
 
 dsLit :: HsLit GhcRn -> DsM CoreExpr
-dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
-dsLit (HsCharPrim   _ c) = return (Lit (MachChar c))
-dsLit (HsIntPrim    _ i) = return (Lit (MachInt i))
-dsLit (HsWordPrim   _ w) = return (Lit (MachWord w))
-dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))
-dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
-dsLit (HsFloatPrim  _ f) = return (Lit (MachFloat (fl_value f)))
-dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d)))
-dsLit (HsChar _ c)       = return (mkCharExpr c)
-dsLit (HsString _ str)   = mkStringExprFS str
-dsLit (HsInteger _ i _)  = mkIntegerExpr i
-dsLit (HsInt _ i)        = do dflags <- getDynFlags
-                              return (mkIntExpr dflags (il_value i))
-
-dsLit (HsRat _ (FL _ _ val) ty) = do
-  num   <- mkIntegerExpr (numerator val)
-  denom <- mkIntegerExpr (denominator val)
-  return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
-  where
-    (ratio_data_con, integer_ty)
-        = case tcSplitTyConApp ty of
-                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
-                                   (head (tyConDataCons tycon), i_ty)
-                x -> pprPanic "dsLit" (ppr x)
+dsLit l = do
+  dflags <- getDynFlags
+  case l of
+    HsStringPrim _ s -> return (Lit (MachStr s))
+    HsCharPrim   _ c -> return (Lit (MachChar c))
+    HsIntPrim    _ i -> return (Lit (mkMachIntWrap dflags i))
+    HsWordPrim   _ w -> return (Lit (mkMachWordWrap dflags w))
+    HsInt64Prim  _ i -> return (Lit (mkMachInt64Wrap dflags i))
+    HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w))
+    HsFloatPrim  _ f -> return (Lit (MachFloat (fl_value f)))
+    HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d)))
+    HsChar _ c       -> return (mkCharExpr c)
+    HsString _ str   -> mkStringExprFS str
+    HsInteger _ i _  -> mkIntegerExpr i
+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
+    XLit x           -> pprPanic "dsLit" (ppr x)
+    HsRat _ (FL _ _ val) ty -> do
+      num   <- mkIntegerExpr (numerator val)
+      denom <- mkIntegerExpr (denominator val)
+      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+      where
+        (ratio_data_con, integer_ty)
+            = case tcSplitTyConApp ty of
+                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+                                       (head (tyConDataCons tycon), i_ty)
+                    x -> pprPanic "dsLit" (ppr x)
 
 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
 dsOverLit lit = do { dflags <- getDynFlags
@@ -108,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags
 dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr
 -- Post-typechecker, the HsExpr field of an OverLit contains
 -- (an expression for) the literal value itself
-dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
-                           , ol_witness = witness, ol_type = ty })
+dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+                           , ol_witness = witness })
   | not rebindable
   , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]
   | otherwise                              = dsExpr witness
-
+dsOverLit' _ XOverLit{} = panic "dsOverLit'"
 {-
 Note [Literal short cut]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -157,20 +161,30 @@ warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM ()
 warnAboutOverflowedLiterals dflags lit
  | wopt Opt_WarnOverflowedLiterals dflags
  , Just (i, tc) <- getIntegralLit lit
-  = if      tc == intTyConName    then check i tc (Proxy :: Proxy Int)
-    else if tc == int8TyConName   then check i tc (Proxy :: Proxy Int8)
-    else if tc == int16TyConName  then check i tc (Proxy :: Proxy Int16)
-    else if tc == int32TyConName  then check i tc (Proxy :: Proxy Int32)
-    else if tc == int64TyConName  then check i tc (Proxy :: Proxy Int64)
-    else if tc == wordTyConName   then check i tc (Proxy :: Proxy Word)
-    else if tc == word8TyConName  then check i tc (Proxy :: Proxy Word8)
-    else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
-    else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
-    else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
+  = if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)
+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
+    else if tc == naturalTyConName then checkPositive i tc
     else return ()
 
   | otherwise = return ()
   where
+    checkPositive :: Integer -> Name -> DsM ()
+    checkPositive i tc
+      = when (i < 0) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> ptext (sLit "only supports positive numbers")
+                     ])
+
     check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
     check i tc _proxy
       = when (i < minB || i > maxB) $ do
@@ -237,14 +251,14 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
 -- See if the expression is an Integral literal
 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
-getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsPar _ e))            = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
 getLHsIntegralLit _ = Nothing
 
 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
   | Just tc <- tyConAppTyCon_maybe ty
   = Just (il_value i, tyConName tc)
 getIntegralLit _ = Nothing
@@ -271,18 +285,13 @@ tidyLitPat (HsString src s)
                   (mkNilPat charTy) (unpackFS s)
         -- The stringTy is the type of the whole pattern, not
         -- the type to instantiate (:) or [] with!
-tidyLitPat lit = LitPat lit
+tidyLitPat lit = LitPat noExt lit
 
 ----------------
-tidyNPat :: (HsLit GhcTc -> Pat GhcTc)   -- How to tidy a LitPat
-                 -- We need this argument because tidyNPat is called
-                 -- both by Match and by Check, but they tidy LitPats
-                 -- slightly differently; and we must desugar
-                 -- literals consistently (see Trac #5117)
-         -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
+tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
          -> Type
          -> Pat GhcTc
-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
+tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
         -- False: Take short cuts only if the literal is not using rebindable syntax
         --
         -- Once that is settled, look for cases where the type of the
@@ -298,7 +307,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
   | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
                  = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
   | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
-                 = tidy_lit_pat (HsString NoSourceText str_lit)
+                 = tidyLitPat (HsString NoSourceText str_lit)
      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
      -- If we do convert to the constructor form, we'll generate a case
      -- expression on a Float# or Double# and that's not allowed in Core; see
@@ -311,7 +320,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
     type_change = not (outer_ty `eqType` ty)
 
     mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
+    mk_con_pat con lit
+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
 
     mb_int_lit :: Maybe Integer
     mb_int_lit = case (mb_neg, val) of
@@ -324,8 +334,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
                    (Nothing, HsIsString _ s) -> Just s
                    _ -> Nothing
 
-tidyNPat _ over_lit mb_neg eq outer_ty
-  = NPat (noLoc over_lit) mb_neg eq outer_ty
+tidyNPat over_lit mb_neg eq outer_ty
+  = NPat outer_ty (noLoc over_lit) mb_neg eq
 
 {-
 ************************************************************************
@@ -359,7 +369,7 @@ matchLiterals (var:vars) ty sub_groups
     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
     match_group eqns
         = do dflags <- getDynFlags
-             let LitPat hs_lit = firstPat (head eqns)
+             let LitPat _ hs_lit = firstPat (head eqns)
              match_result <- match vars ty (shiftEqns eqns)
              return (hsLitKey dflags hs_lit, match_result)
 
@@ -389,8 +399,8 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
 -- HsLit does not.
 hsLitKey dflags (HsIntPrim    _ i) = mkMachIntWrap  dflags i
 hsLitKey dflags (HsWordPrim   _ w) = mkMachWordWrap dflags w
-hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64Wrap       i
-hsLitKey _      (HsWord64Prim _ w) = mkMachWord64Wrap      w
+hsLitKey dflags (HsInt64Prim  _ i) = mkMachInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w
 hsLitKey _      (HsCharPrim   _ c) = mkMachChar            c
 hsLitKey _      (HsFloatPrim  _ f) = mkMachFloat           (fl_value f)
 hsLitKey _      (HsDoublePrim _ d) = mkMachDouble          (fl_value d)
@@ -407,7 +417,7 @@ hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
 
 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
-  = do  { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
+  = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
                             Nothing  -> return lit_expr
@@ -438,7 +448,7 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var:vars) ty (eqn1:eqns)
-  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
+  = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1
         ; lit1_expr   <- dsOverLit lit1
         ; lit2_expr   <- dsOverLit lit2
         ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
@@ -450,7 +460,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
                    adjustMatchResult (foldr1 (.) wraps)         $
                    match_result) }
   where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
         = (wrapBind n n1, eqn { eqn_pats = pats })
         -- The wrapBind is a no-op for the first equation
     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs
index e9af145183..fbacb989a1 100644
--- a/compiler/deSugar/PmExpr.hs
+++ b/compiler/deSugar/PmExpr.hs
@@ -15,12 +15,17 @@ module PmExpr (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
+import BasicTypes (SourceText)
+import FastString (FastString, unpackFS)
 import HsSyn
 import Id
 import Name
 import NameSet
 import DataCon
 import ConLike
+import TcType (isStringTy)
 import TysWiredIn
 import Outputable
 import Util
@@ -234,35 +239,45 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
 
 hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
 
-hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unLoc x))
-hsExprToPmExpr (HsConLikeOut  c) = PmExprVar (conLikeName c)
-hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)
-hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)
-
-hsExprToPmExpr e@(NegApp _ neg_e)
-  | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
-  = PmExprLit (PmOLit True ol)
+hsExprToPmExpr (HsVar        _ x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
+
+-- Desugar literal strings as a list of characters. For other literal values,
+-- keep it as it is.
+-- See `translatePat` in Check.hs (the `NPat` and `LitPat` case), and
+-- Note [Translate Overloaded Literal for Exhaustiveness Checking].
+hsExprToPmExpr (HsOverLit _ olit)
+  | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit, isStringTy ty
+  = stringExprToList src s
+  | otherwise = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit     _ lit)
+  | HsString src s <- lit
+  = stringExprToList src s
+  | otherwise = PmExprLit (PmSLit lit)
+
+hsExprToPmExpr e@(NegApp _ (L _ neg_expr) _)
+  | PmExprLit (PmOLit False olit) <- hsExprToPmExpr neg_expr
+    -- NB: DON'T simply @(NegApp (NegApp olit))@ as @x@. when extension
+    -- @RebindableSyntax@ enabled, (-(-x)) may not equals to x.
+  = PmExprLit (PmOLit True olit)
   | otherwise = PmExprOther e
-hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
 
-hsExprToPmExpr e@(ExplicitTuple ps boxity)
+hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
+
+hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
   | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
   | otherwise            = PmExprOther e
   where
     tuple_con  = tupleDataCon boxity (length ps)
-    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+    tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ]
 
-hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
+hsExprToPmExpr e@(ExplicitList _  mb_ol elems)
   | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
   | otherwise        = PmExprOther e {- overloaded list: No PmExprApp -}
   where
     cons x xs = mkPmExprData consDataCon [x,xs]
     nil       = mkPmExprData nilDataCon  []
 
-hsExprToPmExpr (ExplicitPArr _elem_ty elems)
-  = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
-
-
 -- we want this but we would have to make everything monadic :/
 -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon
 --
@@ -270,20 +285,23 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems)
 --   con  <- dsLookupDataCon (unLoc c)
 --   args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
 --   return (PmExprCon con args)
-hsExprToPmExpr e@(RecordCon   _ _ _ _) = PmExprOther e
-
-hsExprToPmExpr (HsTick            _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsBinTick       _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsTickPragma  _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsSCC           _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsCoreAnn       _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig     e _) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySigOut  e _) = lhsExprToPmExpr e
-hsExprToPmExpr (HsWrap            _ e) =  hsExprToPmExpr e
+hsExprToPmExpr e@(RecordCon {}) = PmExprOther e
+
+hsExprToPmExpr (HsTick           _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsBinTick      _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsSCC          _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsCoreAnn      _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig      _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsWrap           _ _ e) =  hsExprToPmExpr e
 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
 
-synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
-synExprToPmExpr = hsExprToPmExpr . syn_expr  -- ignore the wrappers
+stringExprToList :: SourceText -> FastString -> PmExpr
+stringExprToList src s = foldr cons nil (map charToPmExpr (unpackFS s))
+  where
+    cons x xs      = mkPmExprData consDataCon [x,xs]
+    nil            = mkPmExprData nilDataCon  []
+    charToPmExpr c = PmExprLit (PmSLit (HsChar src c))
 
 {-
 %************************************************************************
@@ -394,7 +412,7 @@ needsParens (PmExprLit    l) = isNegatedPmLit l
 needsParens (PmExprEq    {}) = False -- will become a wildcard
 needsParens (PmExprOther {}) = False -- will become a wildcard
 needsParens (PmExprCon (RealDataCon c) es)
-  | isTupleDataCon c || isPArrFakeCon c
+  | isTupleDataCon c
   || isConsDataCon c || null es = False
   | otherwise                   = True
 needsParens (PmExprCon (PatSynCon _) es) = not (null es)
@@ -407,12 +425,10 @@ pprPmExprWithParens expr
 pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
 pprPmExprCon (RealDataCon con) args
   | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args
-  |  isPArrFakeCon con = mkPArr  <$> mapM pprPmExpr args
-  |  isConsDataCon con = pretty_list
+  | isConsDataCon con  = pretty_list
   where
-    mkTuple, mkPArr :: [SDoc] -> SDoc
+    mkTuple :: [SDoc] -> SDoc
     mkTuple = parens     . fsep . punctuate comma
-    mkPArr  = paBrackets . fsep . punctuate comma
 
     -- lazily, to be used in the list case only
     pretty_list :: PmPprM SDoc
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
index 115c0a882f..d6364bef52 100644
--- a/compiler/deSugar/TmOracle.hs
+++ b/compiler/deSugar/TmOracle.hs
@@ -22,6 +22,8 @@ module TmOracle (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import PmExpr
 
 import Id
@@ -98,6 +100,10 @@ solveOneEq solver_env@(_,(_,env)) complex
   $ applySubstComplexEq env complex -- replace everything we already know
 
 -- | Solve a complex equality.
+-- Nothing => definitely unsatisfiable
+-- Just tms => I have added the complex equality and added
+--             it to the tmstate; the result may or may not be
+--             satisfiable
 solveComplexEq :: TmState -> ComplexEq -> Maybe TmState
 solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
   -- We cannot do a thing about these cases
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index f40c8baed6..5c9d88f8cc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -4,7 +4,7 @@
 Name: ghc
 Version: @ProjectVersionMunged@
 License: BSD3
-License-File: ../LICENSE
+License-File: LICENSE
 Author: The GHC Team
 Maintainer: glasgow-haskell-users@haskell.org
 Homepage: http://www.haskell.org/ghc/
@@ -45,40 +45,55 @@ Flag terminfo
     Default: True
     Manual: True
 
+Flag integer-gmp
+    Description: Use integer-gmp
+    Manual: True
+    Default: False
+
 Library
     Default-Language: Haskell2010
     Exposed: False
 
-    Build-Depends: base       >= 4   && < 5,
+    Build-Depends: base       >= 4.9 && < 5,
                    deepseq    >= 1.4 && < 1.5,
                    directory  >= 1   && < 1.4,
                    process    >= 1   && < 1.7,
                    bytestring >= 0.9 && < 0.11,
                    binary     == 0.8.*,
                    time       >= 1.4 && < 1.9,
-                   containers >= 0.5 && < 0.6,
+                   containers >= 0.5 && < 0.7,
                    array      >= 0.1 && < 0.6,
                    filepath   >= 1   && < 1.5,
-                   template-haskell == 2.12.*,
+                   template-haskell == 2.14.*,
                    hpc        == 0.6.*,
                    transformers == 0.5.*,
                    ghc-boot   == @ProjectVersionMunged@,
                    ghc-boot-th == @ProjectVersionMunged@,
+                   ghc-heap   == @ProjectVersionMunged@,
                    ghci == @ProjectVersionMunged@
 
     if os(windows)
-        Build-Depends: Win32  >= 2.3 && < 2.6
+        Build-Depends: Win32  >= 2.3 && < 2.7
     else
         if flag(terminfo)
             Build-Depends: terminfo == 0.4.*
-        Build-Depends: unix   == 2.7.*
+        Build-Depends: unix   >= 2.7 && < 2.9
 
-    GHC-Options: -Wall -fno-warn-name-shadowing
+    GHC-Options: -Wall
+                 -Wno-name-shadowing
+                 -Wnoncanonical-monad-instances
+                 -Wnoncanonical-monadfail-instances
+                 -Wnoncanonical-monoid-instances
 
     if flag(ghci)
         CPP-Options: -DGHCI
         Include-Dirs: ../rts/dist/build @FFIIncludeDir@
 
+    -- gmp internals are used by the GHCi debugger if available
+    if flag(integer-gmp)
+        CPP-Options: -DINTEGER_GMP
+        build-depends: integer-gmp >= 1.0.2
+
     Other-Extensions:
         BangPatterns
         CPP
@@ -111,14 +126,8 @@ Library
     Include-Dirs: . parser utils
 
     -- We need to set the unit id to ghc (without a version number)
-    -- as it's magic.  But we can't set it for old versions of GHC (e.g.
-    -- when bootstrapping) because those versions of GHC don't understand
-    -- that GHC is wired-in.
-    if impl ( ghc >= 7.11 )
-        GHC-Options: -this-unit-id ghc
-    else
-        if impl( ghc >= 7.9 )
-            GHC-Options: -this-package-key ghc
+    -- as it's magic.
+    GHC-Options: -this-unit-id ghc
 
     if flag(stage1)
         Include-Dirs: stage1
@@ -161,9 +170,16 @@ Library
         typecheck
         types
         utils
-        vectorise
+
+    -- we use an explicit Prelude
+    Default-Extensions:
+        NoImplicitPrelude
+
+    Other-Modules:
+        GhcPrelude
 
     Exposed-Modules:
+        Ar
         FileCleanup
         DriverBkp
         BkpSyn
@@ -284,6 +300,7 @@ Library
         CoreTidy
         CoreUnfold
         CoreUtils
+        CoreMap
         CoreSeq
         CoreStats
         MkCore
@@ -303,6 +320,7 @@ Library
         DsMonad
         DsUsage
         DsUtils
+        ExtractDocs
         Match
         MatchCon
         MatchLit
@@ -314,6 +332,7 @@ Library
         HsLit
         PlaceHolder
         HsExtension
+        HsInstances
         HsPat
         HsSyn
         HsTypes
@@ -360,7 +379,12 @@ Library
         PprTyThing
         StaticPtrTable
         SysTools
+        SysTools.BaseDir
         SysTools.Terminal
+        SysTools.ExtraObj
+        SysTools.Info
+        SysTools.Process
+        SysTools.Tasks
         Elf
         TidyPgm
         Ctype
@@ -379,8 +403,8 @@ Library
         TysPrim
         TysWiredIn
         CostCentre
+        CostCentreState
         ProfInit
-        SCCfinal
         RnBinds
         RnEnv
         RnExpr
@@ -419,9 +443,11 @@ Library
         StgSyn
         CallArity
         DmdAnal
+        Exitify
         WorkWrap
         WwLib
         FamInst
+        ClsInst
         Inst
         TcAnnotations
         TcArrows
@@ -453,12 +479,14 @@ Library
         TcRnTypes
         TcRules
         TcSimplify
+        TcHoleErrors
         TcErrors
         TcTyClsDecls
         TcTyDecls
         TcTypeable
         TcType
         TcEvidence
+        TcEvTerm
         TcUnify
         TcInteract
         TcCanonical
@@ -517,41 +545,11 @@ Library
         UniqMap
         UniqSet
         Util
-        Vectorise.Builtins.Base
-        Vectorise.Builtins.Initialise
-        Vectorise.Builtins
-        Vectorise.Monad.Base
-        Vectorise.Monad.Naming
-        Vectorise.Monad.Local
-        Vectorise.Monad.Global
-        Vectorise.Monad.InstEnv
-        Vectorise.Monad
-        Vectorise.Utils.Base
-        Vectorise.Utils.Closure
-        Vectorise.Utils.Hoisting
-        Vectorise.Utils.PADict
-        Vectorise.Utils.Poly
-        Vectorise.Utils
-        Vectorise.Generic.Description
-        Vectorise.Generic.PAMethods
-        Vectorise.Generic.PADict
-        Vectorise.Generic.PData
-        Vectorise.Type.Env
-        Vectorise.Type.Type
-        Vectorise.Type.TyConDecl
-        Vectorise.Type.Classify
-        Vectorise.Convert
-        Vectorise.Vect
-        Vectorise.Var
-        Vectorise.Env
-        Vectorise.Exp
-        Vectorise
         Hoopl.Block
         Hoopl.Collections
         Hoopl.Dataflow
         Hoopl.Graph
         Hoopl.Label
-        Hoopl.Unique
 --        CgInfoTbls used in ghci/DebuggerUtils
 --        CgHeapery  mkVirtHeapOffsets used in ghci
 
@@ -629,12 +627,4 @@ Library
             Debugger
             Linker
             RtClosureInspect
-            DebuggerUtils
             GHCi
-
-    if !flag(stage1)
-        -- ghc:Serialized moved to ghc-boot:GHC.Serialized.  So for
-        -- compatibility with GHC 7.10 and earlier, we reexport it
-        -- under the old name.
-        reexported-modules:
-            ghc-boot:GHC.Serialized as Serialized
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index bfd75ab26c..9bc6b3f278 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -51,6 +51,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo '{-# LANGUAGE CPP #-}'                                        >> $@
 	@echo 'module Config where'                                         >> $@
 	@echo                                                               >> $@
+	@echo 'import GhcPrelude'                                           >> $@
+	@echo                                                               >> $@
 	@echo '#include "ghc_boot_platform.h"'                              >> $@
 	@echo                                                               >> $@
 	@echo 'data IntegerLibrary = IntegerGMP'                            >> $@
@@ -428,154 +430,6 @@ compiler_stage1_SplitSections = NO
 compiler_stage2_SplitSections = NO
 compiler_stage3_SplitSections = NO
 
-# There are too many symbols in the ghc package for a Windows DLL
-# (due to a limitation of bfd ld, see Trac #5987). We therefore need to split
-# some of the modules off into a separate DLL. This clump are the modules
-# reachable from DynFlags:
-compiler_stage2_dll0_START_MODULE = DynFlags
-compiler_stage2_dll0_MODULES = \
-	Annotations \
-	ApiAnnotation \
-	Avail \
-	Bag \
-	BasicTypes \
-	Binary \
-	BinFingerprint \
-	BooleanFormula \
-	BufWrite \
-	ByteCodeTypes \
-	Class \
-	CmdLineParser \
-	CmmType \
-	CoAxiom \
-	ConLike \
-	Coercion \
-	Config \
-	Constants \
-	CoreArity \
-	CoreFVs \
-	CoreSubst \
-	CoreOpt \
-	CoreSyn \
-	CoreTidy \
-	CoreUnfold \
-	CoreUtils \
-	CoreSeq \
-	CoreStats \
-	CostCentre \
-	DataCon \
-	Demand \
-	Digraph \
-	DriverPhases \
-	DynFlags \
-	Encoding \
-	EnumSet \
-	ErrUtils \
-	Exception \
-	FamInstEnv \
-	FastFunctions \
-	FastMutInt \
-	FastString \
-	FastStringEnv \
-	FieldLabel \
-	FileCleanup \
-	Fingerprint \
-	FiniteMap \
-	ForeignCall \
-	FV \
-	Hooks \
-	HsBinds \
-	HsDecls \
-	HsDoc \
-	HsExpr \
-	HsImpExp \
-	HsLit \
-	PlaceHolder \
-	HsExtension \
-	PmExpr \
-	HsPat \
-	HsSyn \
-	HsTypes \
-	HsUtils \
-	HscTypes \
-	IOEnv \
-	NameCache \
-	Id \
-	IdInfo \
-	IfaceSyn \
-	IfaceType \
-	InteractiveEvalTypes \
-	Json \
-	ToIface \
-	InstEnv \
-	Kind \
-	KnownUniques \
-	Lexeme \
-	ListSetOps \
-	Literal \
-	Maybes \
-	MkCore \
-	MkId \
-	Module \
-	MonadUtils \
-	Name \
-	NameEnv \
-	NameSet \
-	OccName \
-	OccurAnal \
-	OptCoercion \
-	OrdList \
-	Outputable \
-	PackageConfig \
-	Packages \
-	Pair \
-	Panic \
-	PatSyn \
-	PipelineMonad \
-	Platform \
-	PlatformConstants \
-	PprColour \
-	PprCore \
-	PrelNames \
-	PrelRules \
-	Pretty \
-	PrimOp \
-	RepType \
-	RdrName \
-	Rules \
-	SrcLoc \
-	StringBuffer \
-	SysTools.Terminal \
-	TcEvidence \
-	TcRnTypes \
-	TcType \
-	TrieMap \
-	TyCon \
-	Type \
-	TyCoRep \
-	TysPrim \
-	TysWiredIn \
-	Unify \
-	UniqDFM \
-	UniqDSet \
-	UniqFM \
-	UniqSet \
-	UniqSupply \
-	Unique \
-	Util \
-	Var \
-	VarEnv \
-	VarSet
-
-ifeq "$(GhcWithInterpreter)" "YES"
-# These files are reacheable from DynFlags
-# only by GHCi-enabled code (see #9552)
-compiler_stage2_dll0_MODULES += # none
-endif
-
-compiler_stage2_dll0_HS_OBJS = \
-    $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES)))
-
 # if stage is set to something other than "1" or "", disable stage 1
 # See Note [Stage1Only vs stage=1] in mk/config.mk.in.
 ifneq "$(filter-out 1,$(stage))" ""
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index a7395221ce..476a9b2efd 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -15,6 +15,8 @@ module ByteCodeAsm (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import ByteCodeInstr
 import ByteCodeItbls
 import ByteCodeTypes
@@ -123,9 +125,12 @@ mallocStrings hsc_env ulbcos = do
     return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
 
   spliceLit (BCONPtrStr _) = do
-    (RemotePtr p : rest) <- get
-    put rest
-    return (BCONPtrWord (fromIntegral p))
+    rptrs <- get
+    case rptrs of
+      (RemotePtr p : rest) -> do
+        put rest
+        return (BCONPtrWord (fromIntegral p))
+      _ -> panic "mallocStrings:spliceLit"
   spliceLit other = return other
 
   splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
@@ -349,6 +354,12 @@ assembleI dflags i = case i of
   PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
   PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
   PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
+  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]
+  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]
+  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]
+  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]
+  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]
+  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp o1]
   PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
                                  emit bci_PUSH_G [Op p]
   PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
@@ -363,6 +374,15 @@ assembleI dflags i = case i of
                            -> do let ul_bco = assembleBCO dflags proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
                                  emit (push_alts pk) [Op p]
+  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
+  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
+  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
+  PUSH_UBX8 lit            -> do np <- literal lit
+                                 emit bci_PUSH_UBX8 [Op np]
+  PUSH_UBX16 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX16 [Op np]
+  PUSH_UBX32 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX32 [Op np]
   PUSH_UBX lit nws         -> do np <- literal lit
                                  emit bci_PUSH_UBX [Op np, SmallOp nws]
 
@@ -427,17 +447,19 @@ assembleI dflags i = case i of
      -- On Windows, stdcall labels have a suffix indicating the no. of
      -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
     literal (MachLabel fs _ _) = litlabel fs
-    literal (MachWord w)       = int (fromIntegral w)
-    literal (MachInt j)        = int (fromIntegral j)
     literal MachNullAddr       = int 0
     literal (MachFloat r)      = float (fromRational r)
     literal (MachDouble r)     = double (fromRational r)
     literal (MachChar c)       = int (ord c)
-    literal (MachInt64 ii)     = int64 (fromIntegral ii)
-    literal (MachWord64 ii)    = int64 (fromIntegral ii)
     literal (MachStr bs)       = lit [BCONPtrStr bs]
        -- MachStr requires a zero-terminator when emitted
-    literal LitInteger{}       = panic "ByteCodeAsm.literal: LitInteger"
+    literal (LitNumber nt i _) = case nt of
+      LitNumInt     -> int (fromIntegral i)
+      LitNumWord    -> int (fromIntegral i)
+      LitNumInt64   -> int64 (fromIntegral i)
+      LitNumWord64  -> int64 (fromIntegral i)
+      LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+      LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
 
     litlabel fs = lit [BCONPtrLbl fs]
     addr (RemotePtr a) = words [fromIntegral a]
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 2695a98f9e..022fe89306 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fprof-auto-top #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -9,6 +10,8 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import ByteCodeInstr
 import ByteCodeAsm
 import ByteCodeTypes
@@ -43,8 +46,9 @@ import ErrUtils
 import Unique
 import FastString
 import Panic
-import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
-import SMRep
+import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
+import StgCmmLayout
+import SMRep hiding (WordOff, ByteOff, wordsToBytes)
 import Bitmap
 import OrdList
 import Maybes
@@ -68,11 +72,8 @@ import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import qualified FiniteMap as Map
 import Data.Ord
-#if MIN_VERSION_base(4,9,0)
 import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
+import Data.Either ( partitionEithers )
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module
@@ -89,10 +90,10 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
                 (const ()) $ do
         -- Split top-level binds into strings and others.
         -- See Note [generating code for top-level string literal bindings].
-        let (strings, flatBinds) = splitEithers $ do
+        let (strings, flatBinds) = partitionEithers $ do
                 (bndr, rhs) <- flattenBinds binds
-                return $ case rhs of
-                    Lit (MachStr str) -> Left (bndr, str)
+                return $ case exprIsTickedString_maybe rhs of
+                    Just str -> Left (bndr, str)
                     _ -> Right (bndr, simpleFreeVars rhs)
         stringPtrs <- allocateTopStrings hsc_env strings
 
@@ -209,11 +210,33 @@ simpleFreeVars = go . freeVars
 
 type BCInstrList = OrdList BCInstr
 
-type Sequel = Word -- back off to this depth before ENTER
+newtype ByteOff = ByteOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+newtype WordOff = WordOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+wordsToBytes :: DynFlags -> WordOff -> ByteOff
+wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
+
+-- Used when we know we have a whole number of words
+bytesToWords :: DynFlags -> ByteOff -> WordOff
+bytesToWords dflags (ByteOff bytes) =
+    let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
+    in if r == 0
+           then fromIntegral q
+           else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes
+
+wordSize :: DynFlags -> ByteOff
+wordSize dflags = ByteOff (wORD_SIZE dflags)
+
+type Sequel = ByteOff -- back off to this depth before ENTER
+
+type StackDepth = ByteOff
 
 -- | Maps Ids to their stack depth. This allows us to avoid having to mess with
 -- it after each push/pop.
-type BCEnv = Map Id Word -- To find vars on the stack
+type BCEnv = Map Id StackDepth -- To find vars on the stack
 
 {-
 ppBCEnv :: BCEnv -> SDoc
@@ -296,8 +319,6 @@ argBits dflags (rep : args)
 -- Compile code for the right-hand side of a top-level binding
 
 schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
-
-
 schemeTopBind (id, rhs)
   | Just data_con <- isDataConWorkId_maybe id,
     isNullaryRepDataCon data_con = do
@@ -358,7 +379,12 @@ collect (_, e) = go [] e
       = go (x:xs) e
     go xs not_lambda = (reverse xs, not_lambda)
 
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk
+    :: [Id]
+    -> Id
+    -> AnnExpr Id DVarSet
+    -> ([Var], AnnExpr' Var DVarSet)
+    -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
    = do
      dflags <- getDynFlags
@@ -369,27 +395,30 @@ schemeR_wrk fvs nm original_body (args, body)
          -- \fv1..fvn x1..xn -> e
          -- i.e. the fvs come first
 
-         szsw_args = map (fromIntegral . idSizeW dflags) all_args
-         szw_args  = sum szsw_args
-         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
+         -- Stack arguments always take a whole number of words, we never pack
+         -- them unlike constructor fields.
+         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
+         sum_szsb_args  = sum szsb_args
+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
 
          -- make the arg bitmap
          bits = argBits dflags (reverse (map bcIdArgRep all_args))
          bitmap_size = genericLength bits
          bitmap = mkBitmap dflags bits
-     body_code <- schemeER_wrk szw_args p_init body
+     body_code <- schemeER_wrk sum_szsb_args p_init body
 
      emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
-schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
-  = do  code <- schemeE (fromIntegral d) 0 p newRhs
+  = do  code <- schemeE d 0 p newRhs
         cc_arr <- getCCArray
         this_mod <- moduleName <$> getCurrentModule
-        let idOffSets = getVarOffSets d p fvs
+        dflags <- getDynFlags
+        let idOffSets = getVarOffSets dflags d p fvs
         let breakInfo = CgBreakInfo
                         { cgb_vars = idOffSets
                         , cgb_resty = exprType (deAnnotate' newRhs)
@@ -400,10 +429,10 @@ schemeER_wrk d p rhs
                | otherwise = toRemotePtr nullPtr
         let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
         return $ breakInstr `consOL` code
-   | otherwise = schemeE (fromIntegral d) 0 p rhs
+   | otherwise = schemeE d 0 p rhs
 
-getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
-getVarOffSets depth env = catMaybes . map getOffSet
+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets dflags depth env = catMaybes . map getOffSet
   where
     getOffSet id = case lookupBCEnv_maybe id env of
         Nothing     -> Nothing
@@ -415,16 +444,23 @@ getVarOffSets depth env = catMaybes . map getOffSet
             -- this "adjustment" is needed due to stack manipulation for
             -- BRK_FUN in Interpreter.c In any case, this is used only when
             -- we trigger a breakpoint.
-            let adjustment = 2
-            in Just (id, trunc16 $ depth - offset + adjustment)
+            let !var_depth_ws =
+                    trunc16W $ bytesToWords dflags (depth - offset) + 2
+            in Just (id, var_depth_ws)
 
-trunc16 :: Word -> Word16
-trunc16 w
+truncIntegral16 :: Integral a => a -> Word16
+truncIntegral16 w
     | w > fromIntegral (maxBound :: Word16)
     = panic "stack depth overflow"
     | otherwise
     = fromIntegral w
 
+trunc16B :: ByteOff -> Word16
+trunc16B = truncIntegral16
+
+trunc16W :: WordOff -> Word16
+trunc16W = truncIntegral16
+
 fvsToEnv :: BCEnv -> DVarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
 -- delivers an ordered list of the local variables that will
@@ -441,21 +477,26 @@ fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
 -- -----------------------------------------------------------------------------
 -- schemeE
 
-returnUnboxedAtom :: Word -> Sequel -> BCEnv
-                 -> AnnExpr' Id DVarSet -> ArgRep
-                 -> BcM BCInstrList
+returnUnboxedAtom
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr' Id DVarSet
+    -> ArgRep
+    -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
-returnUnboxedAtom d s p e e_rep
-   = do (push, szw) <- pushAtom d p e
-        return (push                       -- value onto stack
-                `appOL`  mkSLIDE szw (d-s) -- clear to sequel
-                `snocOL` RETURN_UBX e_rep) -- go
+returnUnboxedAtom d s p e e_rep = do
+    dflags <- getDynFlags
+    (push, szb) <- pushAtom d p e
+    return (push                                 -- value onto stack
+           `appOL`  mkSlideB dflags szb (d - s)  -- clear to sequel
+           `snocOL` RETURN_UBX e_rep)            -- go
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
-schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-
+schemeE
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeE d s p e
    | Just e' <- bcView e
    = schemeE d s p e'
@@ -478,7 +519,8 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
         -- saturated constructor application.
         -- Just allocate the constructor and carry on
         alloc_code <- mkConAppCode d s p data_con args_r_to_l
-        let !d2 = d + 1
+        dflags <- getDynFlags
+        let !d2 = d + wordSize dflags
         body_code <- schemeE d2 s (Map.insert x d2 p) body
         return (alloc_code `appOL` body_code)
 
@@ -493,28 +535,39 @@ schemeE d s p (AnnLet binds (_,body)) = do
          fvss  = map (fvsToEnv p' . fst) rhss
 
          -- Sizes of free vars
-         sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
+         size_w = trunc16W . idSizeW dflags
+         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
 
          -- the arity of each rhs
          arities = map (genericLength . fst . collect) rhss
 
          -- This p', d' defn is safe because all the items being pushed
-         -- are ptrs, so all have size 1.  d' and p' reflect the stack
+         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.
-         p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
-         d'    = d + fromIntegral n_binds
-         zipE  = zipEqual "schemeE"
+         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
+         p' = Map.insertList (zipE xs offsets) p
+         d' = d + wordsToBytes dflags n_binds
+         zipE = zipEqual "schemeE"
 
          -- ToDo: don't build thunks for things with no free variables
+         build_thunk
+             :: StackDepth
+             -> [Id]
+             -> Word16
+             -> ProtoBCO Name
+             -> Word16
+             -> Word16
+             -> BcM BCInstrList
          build_thunk _ [] size bco off arity
             = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
            where
                 mkap | arity == 0 = MKAP
                      | otherwise  = MKPAP
          build_thunk dd (fv:fvs) size bco off arity = do
-              (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
-              more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
+              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
+              more_push_code <-
+                  build_thunk (dd + pushed_szb) fvs size bco off arity
               return (push_code `appOL` more_push_code)
 
          alloc_code = toOL (zipWith mkAlloc sizes arities)
@@ -532,7 +585,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
                 build_thunk d' fvs size bco off arity
 
          compile_binds =
-            [ compile_bind d' fvs x rhs size arity n
+            [ compile_bind d' fvs x rhs size arity (trunc16W n)
             | (fvs, x, rhs, size, arity, n) <-
                 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
             ]
@@ -661,7 +714,7 @@ schemeE _ _ _ expr
 -- 4.  Otherwise, it must be a function call.  Push the args
 --     right to left, SLIDE and ENTER.
 
-schemeT :: Word         -- Stack depth
+schemeT :: StackDepth   -- Stack depth
         -> Sequel       -- Sequel depth
         -> BCEnv        -- stack env
         -> AnnExpr' Id DVarSet
@@ -669,12 +722,6 @@ schemeT :: Word         -- Stack depth
 
 schemeT d s p app
 
---   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
---   = panic "schemeT ?!?!"
-
---   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
---   = error "?!?!"
-
    -- Case 0
    | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
    = implement_tagToId d s p arg constr_names
@@ -699,8 +746,9 @@ schemeT d s p app
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
    = do alloc_con <- mkConAppCode d s p con args_r_to_l
+        dflags <- getDynFlags
         return (alloc_con         `appOL`
-                mkSLIDE 1 (d - s) `snocOL`
+                mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
                 ENTER)
 
    -- Case 4: Tail call of function
@@ -725,33 +773,48 @@ schemeT d s p app
 -- Generate code to build a constructor application,
 -- leaving it on top of the stack
 
-mkConAppCode :: Word -> Sequel -> BCEnv
-             -> DataCon                 -- The data constructor
-             -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
-             -> BcM BCInstrList
-
+mkConAppCode
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> DataCon                  -- The data constructor
+    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
+    -> BcM BCInstrList
 mkConAppCode _ _ _ con []       -- Nullary constructor
   = ASSERT( isNullaryRepDataCon con )
     return (unitOL (PUSH_G (getName (dataConWorkId con))))
         -- Instead of doing a PACK, which would allocate a fresh
         -- copy of this constructor, use the single shared version.
 
-mkConAppCode orig_d _ p con args_r_to_l
-  = ASSERT( args_r_to_l `lengthIs` dataConRepArity con )
-    do_pushery orig_d (non_ptr_args ++ ptr_args)
- where
-        -- The args are already in reverse order, which is the way PACK
-        -- expects them to be.  We must push the non-ptrs after the ptrs.
-      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
+mkConAppCode orig_d _ p con args_r_to_l =
+    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
+  where
+    app_code = do
+        dflags <- getDynFlags
 
-      do_pushery d (arg:args)
-         = do (push, arg_words) <- pushAtom d p arg
-              more_push_code <- do_pushery (d + fromIntegral arg_words) args
-              return (push `appOL` more_push_code)
-      do_pushery d []
-         = return (unitOL (PACK con n_arg_words))
-         where
-           n_arg_words = trunc16 $ d - orig_d
+        -- The args are initially in reverse order, but mkVirtHeapOffsets
+        -- expects them to be left-to-right.
+        let non_voids =
+                [ NonVoid (prim_rep, arg)
+                | arg <- reverse args_r_to_l
+                , let prim_rep = atomPrimRep arg
+                , not (isVoidRep prim_rep)
+                ]
+            (_, _, args_offsets) =
+                mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
+
+            do_pushery !d (arg : args) = do
+                (push, arg_bytes) <- case arg of
+                    (Padding l _) -> pushPadding l
+                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
+                more_push_code <- do_pushery (d + arg_bytes) args
+                return (push `appOL` more_push_code)
+            do_pushery !d [] = do
+                let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)
+                return (unitOL (PACK con n_arg_words))
+
+        -- Push on the stack in the reverse order.
+        do_pushery orig_d (reverse args_offsets)
 
 
 -- -----------------------------------------------------------------------------
@@ -762,39 +825,41 @@ mkConAppCode orig_d _ p con args_r_to_l
 -- returned, even if it is a pointed type.  We always just return.
 
 unboxedTupleReturn
-        :: Word -> Sequel -> BCEnv
-        -> AnnExpr' Id DVarSet -> BcM BCInstrList
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
 
 doTailCall
-        :: Word -> Sequel -> BCEnv
-        -> Id -> [AnnExpr' Id DVarSet]
-        -> BcM BCInstrList
-doTailCall init_d s p fn args
-  = do_pushes init_d args (map atomRep args)
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> Id
+    -> [AnnExpr' Id DVarSet]
+    -> BcM BCInstrList
+doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
   where
-  do_pushes d [] reps = do
+  do_pushes !d [] reps = do
         ASSERT( null reps ) return ()
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
-        ASSERT( sz == 1 ) return ()
-        return (push_fn `appOL` (
-                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
-                  unitOL ENTER))
-  do_pushes d args reps = do
+        dflags <- getDynFlags
+        ASSERT( sz == wordSize dflags ) return ()
+        let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
+        return (push_fn `appOL` (slide `appOL` unitOL ENTER))
+  do_pushes !d args reps = do
       let (push_apply, n, rest_of_reps) = findPushSeq reps
           (these_args, rest_of_args) = splitAt n args
       (next_d, push_code) <- push_seq d these_args
-      instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+      dflags <- getDynFlags
+      instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
       --                          ^^^ for the PUSH_APPLY_ instruction
       return (push_code `appOL` (push_apply `consOL` instrs))
 
   push_seq d [] = return (d, nilOL)
   push_seq d (arg:args) = do
     (push_code, sz) <- pushAtom d p arg
-    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
+    (final_d, more_push_code) <- push_seq (d + sz) args
     return (final_d, push_code `appOL` more_push_code)
 
 -- v. similar to CgStackery.findMatch, ToDo: merge
@@ -827,10 +892,16 @@ findPushSeq _
 -- -----------------------------------------------------------------------------
 -- Case expressions
 
-doCase  :: Word -> Sequel -> BCEnv
-        -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
-        -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
-        -> BcM BCInstrList
+doCase
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr Id DVarSet
+    -> Id
+    -> [AnnAlt Id DVarSet]
+    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,
+                 -- don't enter the result
+    -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
   | typePrimRep (idType bndr) `lengthExceeds` 1
   = multiValException
@@ -846,30 +917,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- underneath it is the pointer to the alt_code BCO.
         -- When an alt is entered, it assumes the returned value is
         -- on top of the itbl.
-        ret_frame_sizeW :: Word
-        ret_frame_sizeW = 2
+        ret_frame_size_b :: StackDepth
+        ret_frame_size_b = 2 * wordSize dflags
 
         -- The extra frame we push to save/restor the CCCS when profiling
-        save_ccs_sizeW | profiling = 2
-                       | otherwise = 0
+        save_ccs_size_b | profiling = 2 * wordSize dflags
+                        | otherwise = 0
 
         -- An unlifted value gets an extra info table pushed on top
         -- when it is returned.
-        unlifted_itbl_sizeW :: Word
-        unlifted_itbl_sizeW | isAlgCase = 0
-                            | otherwise = 1
+        unlifted_itbl_size_b :: StackDepth
+        unlifted_itbl_size_b | isAlgCase = 0
+                            | otherwise = wordSize dflags
 
         -- depth of stack after the return value has been pushed
-        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
+        d_bndr =
+            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
 
         -- depth of stack after the extra info table for an unboxed return
         -- has been pushed, if any.  This is the stack depth at the
         -- continuation.
-        d_alts = d_bndr + unlifted_itbl_sizeW
+        d_alts = d_bndr + unlifted_itbl_size_b
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves
         p_alts0 = Map.insert bndr d_bndr p
+
         p_alts = case is_unboxed_tuple of
                    Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
                    Nothing       -> p_alts0
@@ -887,23 +960,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | null real_bndrs = do
                 rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
+           -- If an alt attempts to match on an unboxed tuple or sum, we must
+           -- bail out, as the bytecode compiler can't handle them.
+           -- (See Trac #14608.)
+           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
+           = multiValException
            -- algebraic alt with some binders
            | otherwise =
-             let
-                 (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
-                 ptr_sizes    = map (fromIntegral . idSizeW dflags) ptrs
-                 nptrs_sizes  = map (fromIntegral . idSizeW dflags) nptrs
-                 bind_sizes   = ptr_sizes ++ nptrs_sizes
-                 size         = sum ptr_sizes + sum nptrs_sizes
-                 -- the UNPACK instruction unpacks in reverse order...
+             let (tot_wds, _ptrs_wds, args_offsets) =
+                     mkVirtHeapOffsets dflags NoHeader
+                         [ NonVoid (bcIdPrimRep id, id)
+                         | NonVoid id <- nonVoidIds real_bndrs
+                         ]
+                 size = WordOff tot_wds
+
+                 stack_bot = d_alts + wordsToBytes dflags size
+
+                 -- convert offsets from Sp into offsets into the virtual stack
                  p' = Map.insertList
-                        (zip (reverse (ptrs ++ nptrs))
-                          (mkStackOffsets d_alts (reverse bind_sizes)))
+                        [ (arg, stack_bot - ByteOff offset)
+                        | (NonVoid arg, offset) <- args_offsets ]
                         p_alts
              in do
              MASSERT(isAlgCase)
-             rhs_code <- schemeE (d_alts + size) s p' rhs
-             return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
+             rhs_code <- schemeE stack_bot s p' rhs
+             return (my_discr alt,
+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
            where
              real_bndrs = filterOut isTyVar bndrs
 
@@ -914,8 +996,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | otherwise
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
-           = case l of MachInt i     -> DiscrI (fromInteger i)
-                       MachWord w    -> DiscrW (fromInteger w)
+           = case l of LitNumber LitNumInt i  _  -> DiscrI (fromInteger i)
+                       LitNumber LitNumWord w _  -> DiscrW (fromInteger w)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
                        MachChar i    -> DiscrI (ord i)
@@ -942,7 +1024,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- really want a bitmap up to depth (d-s).  This affects compilation of
         -- case-of-case expressions, which is the only time we can be compiling a
         -- case expression with s /= 0.
-        bitmap_size = trunc16 $ d-s
+        bitmap_size = trunc16W $ bytesToWords dflags (d - s)
         bitmap_size' :: Int
         bitmap_size' = fromIntegral bitmap_size
         bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
@@ -954,7 +1036,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           rel_slots = nub $ map fromIntegral $ concat (map spread binds)
           spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
                               | otherwise                      = []
-                where rel_offset = trunc16 $ d - fromIntegral offset
+                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
 
      alt_stuff <- mapM codeAlt alts
      alt_final <- mkMultiBranch maybe_ncons alt_stuff
@@ -966,8 +1048,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --            "\n      bitmap = " ++ show bitmap) $ do
 
-     scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
-                           (d + ret_frame_sizeW + save_ccs_sizeW)
+     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
+                           (d + ret_frame_size_b + save_ccs_size_b)
                            p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
@@ -985,27 +1067,30 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 -- (machine) code for the ccall, and create bytecodes to call that and
 -- then return in the right way.
 
-generateCCall :: Word -> Sequel         -- stack and sequel depths
-              -> BCEnv
-              -> CCallSpec              -- where to call
-              -> Id                     -- of target, for type info
-              -> [AnnExpr' Id DVarSet]   -- args (atoms)
-              -> BcM BCInstrList
-
+generateCCall
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> CCallSpec               -- where to call
+    -> Id                      -- of target, for type info
+    -> [AnnExpr' Id DVarSet]   -- args (atoms)
+    -> BcM BCInstrList
 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
  = do
      dflags <- getDynFlags
 
      let
          -- useful constants
-         addr_sizeW :: Word16
-         addr_sizeW = fromIntegral (argRepSizeW dflags N)
+         addr_size_b :: ByteOff
+         addr_size_b = wordSize dflags
 
          -- Get the args on the stack, with tags and suitably
          -- dereferenced for the CCall.  For each arg, return the
          -- depth to the first word of the bits for that arg, and the
          -- ArgRep of what was actually pushed.
 
+         pargs
+             :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
          pargs _ [] = return []
          pargs d (a:az)
             = let arg_ty = unwrapType (exprType (deAnnotate' a))
@@ -1015,31 +1100,35 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                     -- contains.
                     Just t
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                       -> do rest <- pargs (d + addr_size_b) az
                              code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                      | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
-                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                       -> do rest <- pargs (d + addr_size_b) az
                              code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                       -> do rest <- pargs (d + addr_size_b) az
                              code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
                     _
                        -> do (code_a, sz_a) <- pushAtom d p a
-                             rest <- pargs (d + fromIntegral sz_a) az
+                             rest <- pargs (d + sz_a) az
                              return ((code_a, atomPrimRep a) : rest)
 
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
          -- point to the payload.
-         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
-                          -> BcM BCInstrList
+         parg_ArrayishRep
+             :: Word16
+             -> StackDepth
+             -> BCEnv
+             -> AnnExpr' Id DVarSet
+             -> BcM BCInstrList
          parg_ArrayishRep hdrSize d p a
             = do (push_fo, _) <- pushAtom d p a
                  -- The ptr points at the header.  Advance it over the
@@ -1049,10 +1138,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
      code_n_reps <- pargs d0 args_r_to_l
      let
          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
-         a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
+         a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
 
          push_args    = concatOL pushs_arg
-         d_after_args = d0 + a_reps_sizeW
+         !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
          a_reps_pushed_RAW
             | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
@@ -1104,6 +1193,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
             void marshall_code ( StgWord* ptr_to_top_of_stack )
          -}
          -- resolve static address
+         maybe_static_target :: Maybe Literal
          maybe_static_target =
              case target of
                  DynamicTarget -> Nothing
@@ -1132,18 +1222,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- push the Addr#
          (push_Addr, d_after_Addr)
             | Just machlabel <- maybe_static_target
-            = (toOL [PUSH_UBX machlabel addr_sizeW],
-               d_after_args + fromIntegral addr_sizeW)
+            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
             | otherwise -- is already on the stack
             = (nilOL, d_after_args)
 
          -- Push the return placeholder.  For a call returning nothing,
          -- this is a V (tag).
-         r_sizeW   = fromIntegral (primRepSizeW dflags r_rep)
-         d_after_r = d_after_Addr + fromIntegral r_sizeW
-         push_r    = (if   returns_void
-                      then nilOL
-                      else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
+         r_sizeW   = repSizeWords dflags r_rep
+         d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
+         push_r =
+             if returns_void
+                then nilOL
+                else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
 
          -- generate the marshalling code we're going to call
 
@@ -1151,7 +1241,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- instruction needs to describe the chunk of stack containing
          -- the ccall args to the GC, so it needs to know how large it
          -- is.  See comment in Interpreter.c with the CCALL instruction.
-         stk_offset   = trunc16 $ d_after_r - s
+         stk_offset   = trunc16W $ bytesToWords dflags (d_after_r - s)
 
          conv = case cconv of
            CCallConv -> FFICCall
@@ -1178,7 +1268,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                            PlayRisky         -> 0x2
 
          -- slide and return
-         wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
+         d_after_r_min_s = bytesToWords dflags (d_after_r - s)
+         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
                         `snocOL` RETURN_UBX (toArgRep r_rep)
          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
      return (
@@ -1206,16 +1297,16 @@ primRepToFFIType dflags r
 
 -- Make a dummy literal, to be used as a placeholder for FFI return
 -- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
-mkDummyLiteral pr
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
    = case pr of
-        IntRep    -> MachInt 0
-        WordRep   -> MachWord 0
+        IntRep    -> mkMachInt dflags 0
+        WordRep   -> mkMachWord dflags 0
+        Int64Rep  -> mkMachInt64 0
+        Word64Rep -> mkMachWord64 0
         AddrRep   -> MachNullAddr
         DoubleRep -> MachDouble 0
         FloatRep  -> MachFloat 0
-        Int64Rep  -> MachInt64 0
-        Word64Rep -> MachWord64 0
         _         -> pprPanic "mkDummyLiteral" (ppr pr)
 
 
@@ -1311,18 +1402,25 @@ a 1-word null. See Trac #8383.
 -}
 
 
-implement_tagToId :: Word -> Sequel -> BCEnv
-                  -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
+implement_tagToId
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr' Id DVarSet
+    -> [Name]
+    -> BcM BCInstrList
 -- See Note [Implementing tagToEnum#]
 implement_tagToId d s p arg names
   = ASSERT( notNull names )
-    do (push_arg, arg_words) <- pushAtom d p arg
+    do (push_arg, arg_bytes) <- pushAtom d p arg
        labels <- getLabelsBc (genericLength names)
        label_fail <- getLabelBc
        label_exit <- getLabelBc
+       dflags <- getDynFlags
        let infos = zip4 labels (tail labels ++ [label_fail])
                                [0 ..] names
            steps = map (mkStep label_exit) infos
+           slide_ws = bytesToWords dflags (d - s + arg_bytes)
 
        return (push_arg
                `appOL` unitOL (PUSH_UBX MachNullAddr 1)
@@ -1330,10 +1428,10 @@ implement_tagToId d s p arg names
                `appOL` concatOL steps
                `appOL` toOL [ LABEL label_fail, CASEFAIL,
                               LABEL label_exit ]
-                `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)
+               `appOL` mkSlideW 1 (slide_ws + 1)
                    -- "+1" to account for bogus word
                    --      (see Note [Implementing tagToEnum#])
-                `appOL` unitOL ENTER)
+               `appOL` unitOL ENTER)
   where
         mkStep l_exit (my_label, next_label, n, name_for_n)
            = toOL [LABEL my_label,
@@ -1355,8 +1453,8 @@ implement_tagToId d s p arg names
 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
 -- depth 6 stack has valid words 0 .. 5.
 
-pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
-
+pushAtom
+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
 pushAtom d p e
    | Just e' <- bcView e
    = pushAtom d p e'
@@ -1370,22 +1468,34 @@ pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,
 pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
    = pushAtom d p a
 
-pushAtom d p (AnnVar v)
-   | [] <- typePrimRep (idType v)
+pushAtom d p (AnnVar var)
+   | [] <- typePrimRep (idType var)
    = return (nilOL, 0)
 
-   | isFCallId v
-   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
+   | isFCallId var
+   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)
 
-   | Just primop <- isPrimOpId_maybe v
-   = return (unitOL (PUSH_PRIMOP primop), 1)
+   | Just primop <- isPrimOpId_maybe var
+   = do
+       dflags <-getDynFlags
+       return (unitOL (PUSH_PRIMOP primop), wordSize dflags)
 
-   | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable
+   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable
    = do dflags <- getDynFlags
-        let sz :: Word16
-            sz = fromIntegral (idSizeW dflags v)
-            l = trunc16 $ d - d_v + fromIntegral sz - 1
-        return (toOL (genericReplicate sz (PUSH_L l)), sz)
+
+        let !szb = idSizeCon dflags var
+            with_instr instr = do
+                let !off_b = trunc16B $ d - d_v
+                return (unitOL (instr off_b), wordSize dflags)
+
+        case szb of
+            1 -> with_instr PUSH8_W
+            2 -> with_instr PUSH16_W
+            4 -> with_instr PUSH32_W
+            _ -> do
+                let !szw = bytesToWords dflags szb
+                    !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
+                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
         -- d - d_v           offset from TOS to the first slot of the object
         --
         -- d - d_v + sz - 1  offset from the TOS of the last slot of the object
@@ -1393,47 +1503,78 @@ pushAtom d p (AnnVar v)
         -- Having found the last slot, we proceed to copy the right number of
         -- slots on to the top of the stack.
 
-   | otherwise  -- v must be a global variable
+   | otherwise  -- var must be a global variable
    = do topStrings <- getTopStrings
-        case lookupVarEnv topStrings v of
-            Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
-              ptrToWordPtr $ fromRemotePtr ptr
+        dflags <- getDynFlags
+        case lookupVarEnv topStrings var of
+            Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
+              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
             Nothing -> do
-                dflags <- getDynFlags
-                let sz :: Word16
-                    sz = fromIntegral (idSizeW dflags v)
-                MASSERT(sz == 1)
-                return (unitOL (PUSH_G (getName v)), sz)
+                let sz = idSizeCon dflags var
+                MASSERT( sz == wordSize dflags )
+                return (unitOL (PUSH_G (getName var)), sz)
 
 
 pushAtom _ _ (AnnLit lit) = do
      dflags <- getDynFlags
      let code rep
-             = let size_host_words = fromIntegral (argRepSizeW dflags rep)
-               in  return (unitOL (PUSH_UBX lit size_host_words),
-                           size_host_words)
+             = let size_words = WordOff (argRepSizeW dflags rep)
+               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),
+                           wordsToBytes dflags size_words)
 
      case lit of
         MachLabel _ _ _ -> code N
-        MachWord _    -> code N
-        MachInt _     -> code N
-        MachWord64 _  -> code L
-        MachInt64 _   -> code L
         MachFloat _   -> code F
         MachDouble _  -> code D
         MachChar _    -> code N
         MachNullAddr  -> code N
         MachStr _     -> code N
-        -- No LitInteger's should be left by the time this is called.
-        -- CorePrep should have converted them all to a real core
-        -- representation.
-        LitInteger {} -> panic "pushAtom: LitInteger"
+        LitNumber nt _ _ -> case nt of
+          LitNumInt     -> code N
+          LitNumWord    -> code N
+          LitNumInt64   -> code L
+          LitNumWord64  -> code L
+          -- No LitInteger's or LitNatural's should be left by the time this is
+          -- called. CorePrep should have converted them all to a real core
+          -- representation.
+          LitNumInteger -> panic "pushAtom: LitInteger"
+          LitNumNatural -> panic "pushAtom: LitNatural"
 
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
               (pprCoreExpr (deAnnotate' expr))
 
 
+-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
+-- This is slightly different to @pushAtom@ due to the fact that we allow
+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
+pushConstrAtom
+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
+
+pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) =
+    return (unitOL (PUSH_UBX32 lit), 4)
+
+pushConstrAtom d p (AnnVar v)
+    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable
+        dflags <- getDynFlags
+        let !szb = idSizeCon dflags v
+            done instr = do
+                let !off = trunc16B $ d - d_v
+                return (unitOL (instr off), szb)
+        case szb of
+            1 -> done PUSH8
+            2 -> done PUSH16
+            4 -> done PUSH32
+            _ -> pushAtom d p (AnnVar v)
+
+pushConstrAtom d p expr = pushAtom d p expr
+
+pushPadding :: Int -> BcM (BCInstrList, ByteOff)
+pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
+pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
+pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
+pushPadding x = panic $ "pushPadding x=" ++ show x
+
 -- -----------------------------------------------------------------------------
 -- Given a bunch of alts code and their discrs, do the donkey work
 -- of making a multiway branch using a switch tree.
@@ -1572,11 +1713,14 @@ instance Outputable Discr where
    ppr NoDiscr    = text "DEF"
 
 
-lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
 lookupBCEnv_maybe = Map.lookup
 
-idSizeW :: DynFlags -> Id -> Int
-idSizeW dflags = argRepSizeW dflags . bcIdArgRep
+idSizeW :: DynFlags -> Id -> WordOff
+idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
+
+idSizeCon :: DynFlags -> Id -> ByteOff
+idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
 
 bcIdArgRep :: Id -> ArgRep
 bcIdArgRep = toArgRep . bcIdPrimRep
@@ -1588,6 +1732,9 @@ bcIdPrimRep id
   | otherwise
   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
 
+repSizeWords :: DynFlags -> PrimRep -> WordOff
+repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
+
 isFollowableArg :: ArgRep -> Bool
 isFollowableArg P = True
 isFollowableArg _ = False
@@ -1618,19 +1765,25 @@ unsupportedCConvException = throwGhcException (ProgramError
   ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
    "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
-mkSLIDE :: Word16 -> Word -> OrdList BCInstr
-mkSLIDE n d
-    -- if the amount to slide doesn't fit in a word,
-    -- generate multiple slide instructions
-    | d > fromIntegral limit
-    = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
-    | d == 0
+mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
+mkSlideB dflags !nb !db = mkSlideW n d
+  where
+    !n = trunc16W $ bytesToWords dflags nb
+    !d = bytesToWords dflags db
+
+mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
+mkSlideW !n !ws
+    | ws > fromIntegral limit
+    -- If the amount to slide doesn't fit in a Word16, generate multiple slide
+    -- instructions
+    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)
+    | ws == 0
     = nilOL
     | otherwise
-    = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
-    where
-        limit :: Word16
-        limit = maxBound
+    = unitOL (SLIDE n $ fromIntegral ws)
+  where
+    limit :: Word16
+    limit = maxBound
 
 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
         -- The arguments are returned in *right-to-left* order
@@ -1676,14 +1829,11 @@ atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
 atomRep :: AnnExpr' Id ann -> ArgRep
 atomRep e = toArgRep (atomPrimRep e)
 
-isPtrAtom :: AnnExpr' Id ann -> Bool
-isPtrAtom e = isFollowableArg (atomRep e)
-
--- | Let szsw be the sizes in words of some items pushed onto the stack, which
+-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
 -- has initial depth @original_depth@.  Return the values which the stack
 -- environment should map these items to.
-mkStackOffsets :: Word -> [Word] -> [Word]
-mkStackOffsets original_depth szsw = tail (scanl' (+) original_depth szsw)
+mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
+mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
 
 typeArgRep :: Type -> ArgRep
 typeArgRep = toArgRep . typePrimRep1
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index 525280290f..07dcd2222a 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -12,6 +12,8 @@ module ByteCodeInstr (
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
 
+import GhcPrelude
+
 import ByteCodeTypes
 import GHCi.RemoteTypes
 import GHCi.FFI (C_ffi_cif)
@@ -30,11 +32,7 @@ import PrimOp
 import SMRep
 
 import Data.Word
-#if MIN_VERSION_base(4,9,0)
 import GHC.Stack.CCS (CostCentre)
-#else
-import GHC.Stack (CostCentre)
-#endif
 
 -- ----------------------------------------------------------------------------
 -- Bytecode instructions
@@ -64,6 +62,23 @@ data BCInstr
    | PUSH_LL   !Word16 !Word16{-2 offsets-}
    | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}
 
+   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
+   -- the stack will grow by 8, 16 or 32 bits)
+   | PUSH8  !Word16
+   | PUSH16 !Word16
+   | PUSH32 !Word16
+
+   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
+   -- value will take the whole word on the stack (i.e., the stack will gorw by
+   -- a word)
+   -- This is useful when extracting a packed constructor field for further use.
+   -- Currently we expect all values on the stack to take full words, except for
+   -- the ones used for PACK (i.e., actually constracting new data types, in
+   -- which case we use PUSH{8,16,32})
+   | PUSH8_W  !Word16
+   | PUSH16_W !Word16
+   | PUSH32_W !Word16
+
    -- Push a ptr  (these all map to PUSH_G really)
    | PUSH_G       Name
    | PUSH_PRIMOP  PrimOp
@@ -73,8 +88,16 @@ data BCInstr
    | PUSH_ALTS          (ProtoBCO Name)
    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
 
+   -- Pushing 8, 16 and 32 bits of padding (for constructors).
+   | PUSH_PAD8
+   | PUSH_PAD16
+   | PUSH_PAD32
+
    -- Pushing literals
-   | PUSH_UBX  Literal Word16
+   | PUSH_UBX8  Literal
+   | PUSH_UBX16 Literal
+   | PUSH_UBX32 Literal
+   | PUSH_UBX   Literal Word16
         -- push this int/float/double/addr, on the stack. Word16
         -- is # of words to copy from literal pool.  Eitherness reflects
         -- the difficulty of dealing with MachAddr here, mostly due to
@@ -196,6 +219,12 @@ instance Outputable BCInstr where
    ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset
    ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> ppr o1 <+> ppr o2
    ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
+   ppr (PUSH8  offset)       = text "PUSH8  " <+> ppr offset
+   ppr (PUSH16 offset)       = text "PUSH16  " <+> ppr offset
+   ppr (PUSH32 offset)       = text "PUSH32  " <+> ppr offset
+   ppr (PUSH8_W  offset)     = text "PUSH8_W  " <+> ppr offset
+   ppr (PUSH16_W offset)     = text "PUSH16_W  " <+> ppr offset
+   ppr (PUSH32_W offset)     = text "PUSH32_W  " <+> ppr offset
    ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
    ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."
                                                <> ppr op
@@ -203,6 +232,13 @@ instance Outputable BCInstr where
    ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
    ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
 
+   ppr PUSH_PAD8             = text "PUSH_PAD8"
+   ppr PUSH_PAD16            = text "PUSH_PAD16"
+   ppr PUSH_PAD32            = text "PUSH_PAD32"
+
+   ppr (PUSH_UBX8  lit)      = text "PUSH_UBX8" <+> ppr lit
+   ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
+   ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
    ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
    ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
    ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
@@ -271,11 +307,23 @@ bciStackUse STKCHECK{}            = 0
 bciStackUse PUSH_L{}              = 1
 bciStackUse PUSH_LL{}             = 2
 bciStackUse PUSH_LLL{}            = 3
+bciStackUse PUSH8{}               = 1  -- overapproximation
+bciStackUse PUSH16{}              = 1  -- overapproximation
+bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
+bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
+bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
 bciStackUse PUSH_G{}              = 1
 bciStackUse PUSH_PRIMOP{}         = 1
 bciStackUse PUSH_BCO{}            = 1
 bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
 bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_PAD8)           = 1  -- overapproximation
+bciStackUse (PUSH_PAD16)          = 1  -- overapproximation
+bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
+bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
+bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
 bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
 bciStackUse PUSH_APPLY_N{}        = 1
 bciStackUse PUSH_APPLY_V{}        = 1
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 6dc89e1d9d..7381c8f926 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -9,6 +9,8 @@ module ByteCodeItbls ( mkITbls ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import ByteCodeTypes
 import GHCi
 import DynFlags
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index e865590f2b..e7eb7108f9 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -19,9 +19,10 @@ module ByteCodeLink (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
-import GHCi.InfoTable
 import GHCi.BreakArray
 import SizedSeq
 
@@ -97,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
 lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
 lookupIE hsc_env ie con_nm =
   case lookupNameEnv ie con_nm of
-    Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
+    Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
     Nothing -> do -- try looking up in the object files.
        let sym_to_find1 = nameToCLabel con_nm "con_info"
        m <- lookupSymbol hsc_env sym_to_find1
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
index 1318a47ef4..628b576ca0 100644
--- a/compiler/ghci/ByteCodeTypes.hs
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -13,6 +13,8 @@ module ByteCodeTypes
   , CCostCentre
   ) where
 
+import GhcPrelude
+
 import FastString
 import Id
 import Name
@@ -25,7 +27,6 @@ import SrcLoc
 import GHCi.BreakArray
 import GHCi.RemoteTypes
 import GHCi.FFI
-import GHCi.InfoTable
 import Control.DeepSeq
 
 import Foreign
@@ -34,11 +35,8 @@ import Data.Array.Base  ( UArray(..) )
 import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
-#if MIN_VERSION_base(4,9,0)
+import GHC.Exts.Heap
 import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
 
 -- -----------------------------------------------------------------------------
 -- Compiled Byte Code
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index b40dd5cd89..5942715c12 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -14,6 +14,8 @@
 
 module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
 
+import GhcPrelude
+
 import Linker
 import RtClosureInspect
 
@@ -42,8 +44,6 @@ import Data.List
 import Data.Maybe
 import Data.IORef
 
-import GHC.Exts
-
 -------------------------------------
 -- | The :print & friends commands
 -------------------------------------
@@ -118,11 +118,10 @@ bindSuspensions t = do
           availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
       availNames_var  <- liftIO $ newIORef availNames
       (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
-      let (names, tys, hvals) = unzip3 stuff
+      let (names, tys, fhvs) = unzip3 stuff
       let ids = [ mkVanillaGlobal name ty
                 | (name,ty) <- zip names tys]
           new_ic = extendInteractiveContextWithIds ictxt ids
-      fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
       liftIO $ extendLinkEnv (zip names fhvs)
       setSession hsc_env {hsc_IC = new_ic }
       return t'
@@ -130,7 +129,7 @@ bindSuspensions t = do
 
 --    Processing suspensions. Give names and recopilate info
         nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
-                                   -> TermFold (IO (Term, [(Name,Type,HValue)]))
+                                   -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
         nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
                       {
                         fSuspension = doSuspension hsc_env freeNames
@@ -161,7 +160,7 @@ showTerm term = do
        then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
        else cPprTerm cPprTermBase term
  where
-  cPprShowable prec t@Term{ty=ty, val=val} =
+  cPprShowable prec t@Term{ty=ty, val=fhv} =
     if not (isFullyEvaluatedTerm t)
      then return Nothing
      else do
@@ -174,13 +173,14 @@ showTerm term = do
                       -- does this still do what it is intended to do
                       -- with the changed error handling and logging?
            let noop_log _ _ _ _ _ _ = return ()
-               expr = "show " ++ showPpr dflags bname
+               expr = "Prelude.return (Prelude.show " ++
+                         showPpr dflags bname ++
+                      ") :: Prelude.IO Prelude.String"
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
-           fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
            txt_ <- withExtendedLinkEnv [(bname, fhv)]
-                                       (GHC.compileExpr expr)
+                                       (GHC.compileExprRemote expr)
            let myprec = 10 -- application precedence. TODO Infix constructors
-           let txt = unsafeCoerce# txt_ :: [a]
+           txt <- liftIO $ evalString hsc_env txt_
            if not (null txt) then
              return $ Just $ cparen (prec >= myprec && needsParens txt)
                                     (text txt)
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
deleted file mode 100644
index 9e3d56e0d1..0000000000
--- a/compiler/ghci/DebuggerUtils.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module DebuggerUtils (
-       dataConInfoPtrToName,
-  ) where
-
-import GHCi.InfoTable
-import CmmInfo ( stdInfoTableSizeB )
-import DynFlags
-import FastString
-import TcRnTypes
-import TcRnMonad
-import IfaceEnv
-import Module
-import OccName
-import Name
-import Outputable
-import Util
-
-import Data.Char
-import Foreign
-import Data.List
-
-#include "HsVersions.h"
-
--- | Given a data constructor in the heap, find its Name.
---   The info tables for data constructors have a field which records
---   the source name of the constructor as a Ptr Word8 (UTF-8 encoded
---   string). The format is:
---
---   > Package:Module.Name
---
---   We use this string to lookup the interpreter's internal representation of the name
---   using the lookupOrig.
---
-dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
-dataConInfoPtrToName x = do
-   dflags <- getDynFlags
-   theString <- liftIO $ do
-      let ptr = castPtr x :: Ptr StgInfoTable
-      conDescAddress <- getConDescAddress dflags ptr
-      peekArray0 0 conDescAddress
-   let (pkg, mod, occ) = parse theString
-       pkgFS = mkFastStringByteList pkg
-       modFS = mkFastStringByteList mod
-       occFS = mkFastStringByteList occ
-       occName = mkOccNameFS OccName.dataName occFS
-       modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
-   return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
-    `recoverM` (Right `fmap` lookupOrig modName occName)
-
-   where
-
-   {- To find the string in the constructor's info table we need to consider
-      the layout of info tables relative to the entry code for a closure.
-
-      An info table can be next to the entry code for the closure, or it can
-      be separate. The former (faster) is used in registerised versions of ghc,
-      and the latter (portable) is for non-registerised versions.
-
-      The diagrams below show where the string is to be found relative to
-      the normal info table of the closure.
-
-      1) Code next to table:
-
-         --------------
-         |            |   <- pointer to the start of the string
-         --------------
-         |            |   <- the (start of the) info table structure
-         |            |
-         |            |
-         --------------
-         | entry code |
-         |    ....    |
-
-         In this case the pointer to the start of the string can be found in
-         the memory location _one word before_ the first entry in the normal info
-         table.
-
-      2) Code NOT next to table:
-
-                                 --------------
-         info table structure -> |     *------------------> --------------
-                                 |            |             | entry code |
-                                 |            |             |    ....    |
-                                 --------------
-         ptr to start of str ->  |            |
-                                 --------------
-
-         In this case the pointer to the start of the string can be found
-         in the memory location: info_table_ptr + info_table_size
-   -}
-
-   getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
-   getConDescAddress dflags ptr
-    | ghciTablesNextToCode = do
-       let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)
-       -- NB. the offset must be read as an Int32 not a Word32, so
-       -- that the sign is preserved when converting to an Int.
-       offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32)
-       return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString
-    | otherwise =
-       peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
-   -- parsing names is a little bit fiddly because we have a string in the form:
-   -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
-   -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
-   -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
-   -- this is not the conventional way of writing Haskell names. We stick with
-   -- convention, even though it makes the parsing code more troublesome.
-   -- Warning: this code assumes that the string is well formed.
-   parse :: [Word8] -> ([Word8], [Word8], [Word8])
-   parse input
-      = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ)
-      where
-      dot = fromIntegral (ord '.')
-      (pkg, rest1) = break (== fromIntegral (ord ':')) input
-      (mod, occ)
-         = (concat $ intersperse [dot] $ reverse modWords, occWord)
-         where
-         (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1))
-      parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
-      -- We only look for dots if str could start with a module name,
-      -- i.e. if it starts with an upper case character.
-      -- Otherwise we might think that "X.:->" is the module name in
-      -- "X.:->.+", whereas actually "X" is the module name and
-      -- ":->.+" is a constructor name.
-      parseModOcc acc str@(c : _)
-       | isUpper $ chr $ fromIntegral c
-         = case break (== dot) str of
-              (top, []) -> (acc, top)
-              (top, _ : bot) -> parseModOcc (top : acc) bot
-      parseModOcc acc str = (acc, str)
diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hs
index d2f2f5a833..579053999f 100644
--- a/compiler/ghci/GHCi.hsc
+++ b/compiler/ghci/GHCi.hs
@@ -21,6 +21,8 @@ module GHCi
   , enableBreakpoint
   , breakpointStatus
   , getBreakpointVar
+  , getClosure
+  , seqHValue
 
   -- * The object-code linker
   , initObjLinker
@@ -46,6 +48,8 @@ module GHCi
   , fromEvalResult
   ) where
 
+import GhcPrelude
+
 import GHCi.Message
 #if defined(GHCI)
 import GHCi.Run
@@ -75,23 +79,14 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LB
 import Data.IORef
 import Foreign hiding (void)
-#if MIN_VERSION_base(4,9,0)
+import GHC.Exts.Heap
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
-#else
-import GHC.Stack (CostCentre,CostCentreStack)
-#endif
 import System.Exit
 import Data.Maybe
 import GHC.IO.Handle.Types (Handle)
 #if defined(mingw32_HOST_OS)
 import Foreign.C
 import GHC.IO.Handle.FD (fdToHandle)
-#if !MIN_VERSION_process(1,4,2)
-import System.Posix.Internals
-import Foreign.Marshal.Array
-import Foreign.C.Error
-import Foreign.Storable
-#endif
 #else
 import System.Posix as Posix
 #endif
@@ -358,6 +353,17 @@ getBreakpointVar hsc_env ref ix =
     mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
     mapM (mkFinalizedHValue hsc_env) mb
 
+getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure hsc_env ref =
+  withForeignRef ref $ \hval -> do
+    mb <- iservCmd hsc_env (GetClosure hval)
+    mapM (mkFinalizedHValue hsc_env) mb
+
+seqHValue :: HscEnv -> ForeignHValue -> IO ()
+seqHValue hsc_env ref =
+  withForeignRef ref $ \hval ->
+    iservCmd hsc_env (Seq hval) >>= fromEvalResult
+
 -- -----------------------------------------------------------------------------
 -- Interface to the object-code linker
 
@@ -545,22 +551,6 @@ runWithPipes createProc prog opts = do
       where mkHandle :: CInt -> IO Handle
             mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
 
-#if !MIN_VERSION_process(1,4,2)
--- This #include and the _O_BINARY below are the only reason this is hsc,
--- so we can remove that once we can depend on process 1.4.2
-#include <fcntl.h>
-
-createPipeFd :: IO (FD, FD)
-createPipeFd = do
-    allocaArray 2 $ \ pfds -> do
-        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
-        readfd <- peek pfds
-        writefd <- peekElemOff pfds 1
-        return (readfd, writefd)
-
-foreign import ccall "io.h _pipe" c__pipe ::
-    Ptr CInt -> CUInt -> CInt -> IO CInt
-#endif
 #else
 runWithPipes createProc prog opts = do
     (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
@@ -584,7 +574,7 @@ We have the following ways to reference things in GHCi:
 HValue
 ------
 
-HValue is a direct reference to an value in the local heap.  Obviously
+HValue is a direct reference to a value in the local heap.  Obviously
 we cannot use this to refer to things in the external process.
 
 
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index aee7684157..9f1307d798 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_GHC -fno-cse #-}
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
@@ -20,6 +21,8 @@ module Linker ( getHValue, showLinkerState,
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import GHCi
 import GHCi.RemoteTypes
 import LoadIface
@@ -51,8 +54,8 @@ import FileCleanup
 
 -- Standard libraries
 import Control.Monad
-import Control.Applicative((<|>))
 
+import Data.Char (isSpace)
 import Data.IORef
 import Data.List
 import Data.Maybe
@@ -60,10 +63,19 @@ import Control.Concurrent.MVar
 
 import System.FilePath
 import System.Directory
+import System.IO.Unsafe
+import System.Environment (lookupEnv)
+
+#if defined(mingw32_HOST_OS)
+import System.Win32.Info (getSystemDirectory)
+#endif
 
 import Exception
 
-import Foreign (Ptr) -- needed for 2nd stage
+-- needed for 2nd stage
+#if STAGE >= 2
+import Foreign (Ptr)
+#endif
 
 {- **********************************************************************
 
@@ -75,35 +87,45 @@ import Foreign (Ptr) -- needed for 2nd stage
 The persistent linker state *must* match the actual state of the
 C dynamic linker at all times, so we keep it in a private global variable.
 
-The global IORef used for PersistentLinkerState actually contains another MVar.
-The reason for this is that we want to allow another loaded copy of the GHC
-library to side-effect the PLS and for those changes to be reflected here.
+The global IORef used for PersistentLinkerState actually contains another MVar,
+which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure
+mutual exclusion between multiple loaded copies of the GHC library. The Maybe
+may be Nothing to indicate that the linker has not yet been initialised.
 
 The PersistentLinkerState maps Names to actual closures (for
 interpreted code only), for use during linking.
 -}
 #if STAGE < 2
-GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
-GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
+GLOBAL_VAR_M( v_PersistentLinkerState
+            , newMVar Nothing
+            , MVar (Maybe PersistentLinkerState))
 #else
 SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
                    , getOrSetLibHSghcPersistentLinkerState
                    , "getOrSetLibHSghcPersistentLinkerState"
-                   , newMVar (panic "Dynamic linker not initialised")
-                   , MVar PersistentLinkerState)
--- Set True when dynamic linker is initialised
-SHARED_GLOBAL_VAR( v_InitLinkerDone
-                 , getOrSetLibHSghcInitLinkerDone
-                 , "getOrSetLibHSghcInitLinkerDone"
-                 , False
-                 , Bool)
+                   , newMVar Nothing
+                   , MVar (Maybe PersistentLinkerState))
 #endif
 
+uninitialised :: a
+uninitialised = panic "Dynamic linker not initialised"
+
 modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
-modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
+modifyPLS_ f = readIORef v_PersistentLinkerState
+  >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)
 
 modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
-modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f
+modifyPLS f = readIORef v_PersistentLinkerState
+  >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)
+  where fmapFst f = fmap (\(x, y) -> (f x, y))
+
+readPLS :: IO PersistentLinkerState
+readPLS = readIORef v_PersistentLinkerState
+  >>= fmap (fromMaybe uninitialised) . readMVar
+
+modifyMbPLS_
+  :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
+modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
 
 data PersistentLinkerState
    = PersistentLinkerState {
@@ -158,10 +180,10 @@ extendLoadedPkgs pkgs =
 
 extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
 extendLinkEnv new_bindings =
-  modifyPLS_ $ \pls -> do
-    let ce = closure_env pls
-    let new_ce = extendClosureEnv ce new_bindings
-    return pls{ closure_env = new_ce }
+  modifyPLS_ $ \pls@PersistentLinkerState{..} -> do
+    let new_ce = extendClosureEnv closure_env new_bindings
+    return $! pls{ closure_env = new_ce }
+    -- strictness is important for not retaining old copies of the pls
 
 deleteFromLinkEnv :: [Name] -> IO ()
 deleteFromLinkEnv to_remove =
@@ -243,7 +265,7 @@ withExtendedLinkEnv new_env action
 -- | Display the persistent linker state.
 showLinkerState :: DynFlags -> IO ()
 showLinkerState dflags
-  = do pls <- readIORef v_PersistentLinkerState >>= readMVar
+  = do pls <- readPLS
        putLogMsg dflags NoReason SevDump noSrcSpan
           (defaultDumpStyle dflags)
                  (vcat [text "----- Linker state -----",
@@ -278,11 +300,10 @@ showLinkerState dflags
 --
 initDynLinker :: HscEnv -> IO ()
 initDynLinker hsc_env =
-  modifyPLS_ $ \pls0 -> do
-    done <- readIORef v_InitLinkerDone
-    if done then return pls0
-            else do writeIORef v_InitLinkerDone True
-                    reallyInitDynLinker hsc_env
+  modifyMbPLS_ $ \pls -> do
+    case pls of
+      Just  _ -> return pls
+      Nothing -> Just <$> reallyInitDynLinker hsc_env
 
 reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
 reallyInitDynLinker hsc_env = do
@@ -310,7 +331,8 @@ linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
 linkCmdLineLibs' hsc_env pls =
   do
       let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
-                           , libraryPaths = lib_paths}) = hsc_dflags hsc_env
+                           , libraryPaths = lib_paths_base})
+            = hsc_dflags hsc_env
 
       -- (c) Link libraries from the command-line
       let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
@@ -325,8 +347,18 @@ linkCmdLineLibs' hsc_env pls =
           minus_ls = case os of
                        OSMinGW32 -> "pthread" : minus_ls_1
                        _         -> minus_ls_1
+      -- See Note [Fork/Exec Windows]
+      gcc_paths <- getGCCPaths dflags os
+
+      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
 
-      libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
+      maybePutStrLn dflags "Search directories (user):"
+      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)
+      maybePutStrLn dflags "Search directories (gcc):"
+      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)
+
+      libspecs
+        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
 
       -- (d) Link .o files from the command-line
       classified_ld_inputs <- mapM (classifyLdInput dflags)
@@ -350,10 +382,12 @@ linkCmdLineLibs' hsc_env pls =
       -- on Windows. On Unix OSes this function is a NOP.
       let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)
                                 : framework_paths
-                               ++ lib_paths
+                               ++ lib_paths_base
                                ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
                       in nub $ map normalise paths
-      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
+      let lib_paths = nub $ lib_paths_base ++ gcc_paths
+      all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
 
       pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
                     cmdline_lib_specs
@@ -483,9 +517,17 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
        = do b <- doesFileExist name
             if not b then return False
                      else do if dynamicGhc
-                                 then panic "Loading archives not supported"
+                                 then throwGhcExceptionIO $
+                                      CmdLineError dynamic_msg
                                  else loadArchive hsc_env name
                              return True
+      where
+        dynamic_msg = unlines
+          [ "User-specified static library could not be loaded ("
+            ++ name ++ ")"
+          , "Loading static libraries is not supported in this configuration."
+          , "Try using a dynamic library instead."
+          ]
 
 
 {- **********************************************************************
@@ -722,15 +764,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
             adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
             adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
             adjust_ul _ l@(BCOs {}) = return l
-#if !MIN_VERSION_filepath(1,4,1)
-    stripExtension :: String -> FilePath -> Maybe FilePath
-    stripExtension []        path = Just path
-    stripExtension ext@(x:_) path = stripSuffix dotExt path
-        where dotExt = if isExtSeparator x then ext else '.':ext
-
-    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
-    stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)
-#endif
 
 
 
@@ -895,16 +928,14 @@ dynLoadObjs hsc_env pls objs = do
                       -- can resolve dependencies when it loads this
                       -- library.
                       ldInputs =
-                        concatMap
-                            (\(lp, l) ->
-                                 [ Option ("-L" ++ lp)
-                                 , Option "-Xlinker"
-                                 , Option "-rpath"
-                                 , Option "-Xlinker"
-                                 , Option lp
-                                 , Option ("-l" ++  l)
-                                 ])
-                            (temp_sos pls)
+                           concatMap (\l -> [ Option ("-l" ++ l) ])
+                                     (nub $ snd <$> temp_sos pls)
+                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)
+                                                    , Option "-Xlinker"
+                                                    , Option "-rpath"
+                                                    , Option "-Xlinker"
+                                                    , Option lp ])
+                                     (nub $ fst <$> temp_sos pls)
                         ++ concatMap
                              (\lp ->
                                  [ Option ("-L" ++ lp)
@@ -1072,15 +1103,19 @@ unload_wkr :: HscEnv
 -- Does the core unload business
 -- (the wrapper blocks exceptions and deals with the PLS get and put)
 
-unload_wkr hsc_env keep_linkables pls = do
+unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do
+  -- NB. careful strictness here to avoid keeping the old PLS when
+  -- we're unloading some code.  -fghci-leak-check with the tests in
+  -- testsuite/ghci can detect space leaks here.
+
   let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
 
       discard keep l = not (linkableInSet l keep)
 
       (objs_to_unload, remaining_objs_loaded) =
-         partition (discard objs_to_keep) (objs_loaded pls)
+         partition (discard objs_to_keep) objs_loaded
       (bcos_to_unload, remaining_bcos_loaded) =
-         partition (discard bcos_to_keep) (bcos_loaded pls)
+         partition (discard bcos_to_keep) bcos_loaded
 
   mapM_ unloadObjs objs_to_unload
   mapM_ unloadObjs bcos_to_unload
@@ -1091,7 +1126,7 @@ unload_wkr hsc_env keep_linkables pls = do
                    filter (not . null . linkableObjs) bcos_to_unload))) $
     purgeLookupSymbolCache hsc_env
 
-  let bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
+  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
 
       -- Note that we want to remove all *local*
       -- (i.e. non-isExternal) names too (these are the
@@ -1099,13 +1134,13 @@ unload_wkr hsc_env keep_linkables pls = do
       keep_name (n,_) = isExternalName n &&
                         nameModule n `elemModuleSet` bcos_retained
 
-      itbl_env'     = filterNameEnv keep_name (itbl_env pls)
-      closure_env'  = filterNameEnv keep_name (closure_env pls)
+      itbl_env'     = filterNameEnv keep_name itbl_env
+      closure_env'  = filterNameEnv keep_name closure_env
 
-      new_pls = pls { itbl_env = itbl_env',
-                      closure_env = closure_env',
-                      bcos_loaded = remaining_bcos_loaded,
-                      objs_loaded = remaining_objs_loaded }
+      !new_pls = pls { itbl_env = itbl_env',
+                       closure_env = closure_env',
+                       bcos_loaded = remaining_bcos_loaded,
+                       objs_loaded = remaining_objs_loaded }
 
   return new_pls
   where
@@ -1250,9 +1285,14 @@ linkPackage hsc_env pkg
                             then Packages.extraLibraries pkg
                             else Packages.extraGHCiLibraries pkg)
                       ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
-
-        hs_classifieds    <- mapM (locateLib hsc_env True  dirs) hs_libs'
-        extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs
+        -- See Note [Fork/Exec Windows]
+        gcc_paths <- getGCCPaths dflags (platformOS platform)
+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
+
+        hs_classifieds
+           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'
+        extra_classifieds
+           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs
         let classifieds = hs_classifieds ++ extra_classifieds
 
         -- Complication: all the .so's must be loaded before any of the .o's.
@@ -1264,7 +1304,8 @@ linkPackage hsc_env pkg
         -- Add directories to library search paths
         let dll_paths  = map takeDirectory known_dlls
             all_paths  = nub $ map normalise $ dll_paths ++ dirs
-        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
+        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
 
         maybePutStr dflags
             ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
@@ -1306,8 +1347,8 @@ load_dyn hsc_env dll = do
   r <- loadDLL hsc_env dll
   case r of
     Nothing  -> return ()
-    Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
-                                                ++ dll ++ " (" ++ err ++ ")" ))
+    Just err -> cmdLineErrorIO ("can't load .so/.DLL for: "
+                                ++ dll ++ " (" ++ err ++ ")")
 
 loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
 loadFrameworks hsc_env platform pkg
@@ -1319,8 +1360,8 @@ loadFrameworks hsc_env platform pkg
     load fw = do  r <- loadFramework hsc_env fw_dirs fw
                   case r of
                     Nothing  -> return ()
-                    Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
-                                                        ++ fw ++ " (" ++ err ++ ")" ))
+                    Just err -> cmdLineErrorIO ("can't load framework: "
+                                                ++ fw ++ " (" ++ err ++ ")" )
 
 -- Try to find an object file for a given library in the given paths.
 -- If it isn't present, we assume that addDLL in the RTS can find it,
@@ -1328,25 +1369,40 @@ loadFrameworks hsc_env platform pkg
 -- standard system search path.
 -- For GHCi we tend to prefer dynamic libraries over static ones as
 -- they are easier to load and manage, have less overhead.
-locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec
-locateLib hsc_env is_hs dirs lib
+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
+          -> IO LibrarySpec
+locateLib hsc_env is_hs lib_dirs gcc_dirs lib
   | not is_hs
     -- For non-Haskell libraries (e.g. gmp, iconv):
-    --   first look in library-dirs for a dynamic library (libfoo.so)
+    --   first look in library-dirs for a dynamic library (on User paths only)
+    --   (libfoo.so)
+    --   then  try looking for import libraries on Windows (on User paths only)
+    --   (.dll.a, .lib)
+    --   first look in library-dirs for a dynamic library (on GCC paths only)
+    --   (libfoo.so)
+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
+    --   then  try looking for import libraries on Windows (on GCC paths only)
+    --   (.dll.a, .lib)
     --   then  look in library-dirs for a static library (libfoo.a)
     --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
-    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
     --   then  try looking for import libraries on Windows (.dll.a, .lib)
-    --   then  try "gcc --print-file-name" to search gcc's search path
     --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
+    --   then  try "gcc --print-file-name" to search gcc's search path
     --       for a dynamic library (#5289)
     --   otherwise, assume loadDLL can find it
     --
-  = findDll     `orElse`
-    findSysDll  `orElse`
-    tryImpLib   `orElse`
-    tryGcc      `orElse`
-    findArchive `orElse`
+    --   The logic is a bit complicated, but the rationale behind it is that
+    --   loading a shared library for us is O(1) while loading an archive is
+    --   O(n). Loading an import library is also O(n) so in general we prefer
+    --   shared libraries because they are simpler and faster.
+    --
+  = findDll   user `orElse`
+    tryImpLib user `orElse`
+    findDll   gcc  `orElse`
+    findSysDll     `orElse`
+    tryImpLib gcc  `orElse`
+    findArchive    `orElse`
+    tryGcc         `orElse`
     assumeDll
 
   | loading_dynamic_hs_libs -- search for .so libraries first.
@@ -1367,11 +1423,15 @@ locateLib hsc_env is_hs dirs lib
 
    where
      dflags = hsc_dflags hsc_env
+     dirs   = lib_dirs ++ gcc_dirs
+     gcc    = False
+     user   = True
 
      obj_file     = lib <.> "o"
      dyn_obj_file = lib <.> "dyn_o"
      arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
                   , lib <.> "a" -- native code has no lib_tag
+                  , "lib" ++ lib, lib
                   ]
      lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
 
@@ -1393,19 +1453,26 @@ locateLib hsc_env is_hs dirs lib
 
      findObject    = liftM (fmap Object)  $ findFile dirs obj_file
      findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file
-     findArchive   = let local  name = liftM (fmap Archive) $ findFile dirs name
-                         linked name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs
-                         check name = apply [local name, linked name]
-                     in  apply (map check arch_files)
+     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
+                     in  apply (map local arch_files)
      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
-     findDll       = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
-     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name
-     tryGcc        = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name     dirs
-                         full  = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
-                     in liftM2 (<|>) short full
-     tryImpLib     = case os of
-                       OSMinGW32 -> let check name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs
-                                    in apply (map check import_libs)
+     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs
+                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $
+                        findSystemLibrary hsc_env so_name
+     tryGcc        = let search   = searchForLibUsingGcc dflags
+                         dllpath  = liftM (fmap DLLPath)
+                         short    = dllpath $ search so_name lib_dirs
+                         full     = dllpath $ search lib_so_name lib_dirs
+                         gcc name = liftM (fmap Archive) $ search name lib_dirs
+                         files    = import_libs ++ arch_files
+                     in apply $ short : full : map gcc files
+     tryImpLib re = case os of
+                       OSMinGW32 ->
+                        let dirs' = if re == user then lib_dirs else gcc_dirs
+                            implib name = liftM (fmap Archive) $
+                                            findFile dirs' name
+                        in apply (map implib import_libs)
                        _         -> return Nothing
 
      assumeDll   = return (DLL lib)
@@ -1435,6 +1502,96 @@ searchForLibUsingGcc dflags so dirs = do
       then return Nothing
       else return (Just file)
 
+-- | Retrieve the list of search directory GCC and the System use to find
+--   libraries and components. See Note [Fork/Exec Windows].
+getGCCPaths :: DynFlags -> OS -> IO [FilePath]
+getGCCPaths dflags os
+  = case os of
+      OSMinGW32 ->
+        do gcc_dirs <- getGccSearchDirectory dflags "libraries"
+           sys_dirs <- getSystemDirectories
+           return $ nub $ gcc_dirs ++ sys_dirs
+      _         -> return []
+
+-- | Cache for the GCC search directories as this can't easily change
+--   during an invocation of GHC. (Maybe with some env. variable but we'll)
+--   deal with that highly unlikely scenario then.
+{-# NOINLINE gccSearchDirCache #-}
+gccSearchDirCache :: IORef [(String, [String])]
+gccSearchDirCache = unsafePerformIO $ newIORef []
+
+-- Note [Fork/Exec Windows]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we
+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
+-- So instead get a list of location that GCC would search and use findDirs
+-- which hopefully is written in an optimized mannor to take advantage of
+-- caching. At the very least we remove the overhead of the fork/exec and waits
+-- which dominate a large percentage of startup time on Windows.
+getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]
+getGccSearchDirectory dflags key = do
+    cache <- readIORef gccSearchDirCache
+    case lookup key cache of
+      Just x  -> return x
+      Nothing -> do
+        str <- askLd dflags [Option "--print-search-dirs"]
+        let line = dropWhile isSpace str
+            name = key ++ ": ="
+        if null line
+          then return []
+          else do let val = split $ find name line
+                  dirs <- filterM doesDirectoryExist val
+                  modifyIORef' gccSearchDirCache ((key, dirs):)
+                  return val
+      where split :: FilePath -> [FilePath]
+            split r = case break (==';') r of
+                        (s, []    ) -> [s]
+                        (s, (_:xs)) -> s : split xs
+
+            find :: String -> String -> String
+            find r x = let lst = lines x
+                           val = filter (r `isPrefixOf`) lst
+                       in if null val
+                             then []
+                             else case break (=='=') (head val) of
+                                     (_ , [])    -> []
+                                     (_, (_:xs)) -> xs
+
+-- | Get a list of system search directories, this to alleviate pressure on
+-- the findSysDll function.
+getSystemDirectories :: IO [FilePath]
+#if defined(mingw32_HOST_OS)
+getSystemDirectories = fmap (:[]) getSystemDirectory
+#else
+getSystemDirectories = return []
+#endif
+
+-- | Merge the given list of paths with those in the environment variable
+--   given. If the variable does not exist then just return the identity.
+addEnvPaths :: String -> [String] -> IO [String]
+addEnvPaths name list
+  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
+       -- working directory. Replace empty strings in the env variable with
+       -- `working_dir` (see also #14695).
+       working_dir <- getCurrentDirectory
+       values <- lookupEnv name
+       case values of
+         Nothing  -> return list
+         Just arr -> return $ list ++ splitEnv working_dir arr
+    where
+      splitEnv :: FilePath -> String -> [String]
+      splitEnv working_dir value =
+        case break (== envListSep) value of
+          (x, []    ) ->
+            [if null x then working_dir else x]
+          (x, (_:xs)) ->
+            (if null x then working_dir else x) : splitEnv working_dir xs
+#if defined(mingw32_HOST_OS)
+      envListSep = ';'
+#else
+      envListSep = ':'
+#endif
+
 -- ----------------------------------------------------------------------------
 -- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
 
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 785513b3b6..18feeb523f 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -8,28 +8,27 @@
 --
 -----------------------------------------------------------------------------
 module RtClosureInspect(
-     cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
+     -- * Entry points and types
+     cvObtainTerm,
      cvReconstructType,
      improveRTTIType,
-
      Term(..),
-     isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
-     isFullyEvaluated, isFullyEvaluatedTerm,
-     termType, mapTermType, termTyCoVars,
-     foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
-     pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
 
---     unsafeDeepSeq,
+     -- * Utils
+     isFullyEvaluatedTerm,
+     termType, mapTermType, termTyCoVars,
+     foldTerm, TermFold(..),
+     cPprTerm, cPprTermBase,
 
-     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
+     constrClosToName -- exported to use in test T4891
  ) where
 
 #include "HsVersions.h"
 
-import DebuggerUtils
-import GHCi.RemoteTypes ( HValue )
-import qualified GHCi.InfoTable as InfoTable
-import GHCi.InfoTable (StgInfoTable, peekItbl)
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
 import HscTypes
 
 import DataCon
@@ -40,12 +39,15 @@ import Var
 import TcRnMonad
 import TcType
 import TcMType
-import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )
+import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
 import TcUnify
 import TcEnv
 
 import TyCon
 import Name
+import OccName
+import Module
+import IfaceEnv
 import Util
 import VarSet
 import BasicTypes       ( Boxity(..) )
@@ -54,20 +56,25 @@ import PrelNames
 import TysWiredIn
 import DynFlags
 import Outputable as Ppr
-import GHC.Arr          ( Array(..) )
+import GHC.Char
 import GHC.Exts
+import GHC.Exts.Heap
 import GHC.IO ( IO(..) )
+import SMRep ( roundUpTo )
 
 import Control.Monad
-import Data.Maybe
 import Data.Array.Base
-import Data.Ix
+import Data.Maybe
 import Data.List
+#if defined(INTEGER_GMP)
+import GHC.Integer.GMP.Internals
+#endif
 import qualified Data.Sequence as Seq
 import Data.Sequence (viewl, ViewL(..))
 import Foreign
 import System.IO.Unsafe
 
+
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -77,15 +84,15 @@ data Term = Term { ty        :: RttiType
                                -- Carries a text representation if the datacon is
                                -- not exported by the .hi file, which is the case
                                -- for private constructors in -O0 compiled libraries
-                 , val       :: HValue
+                 , val       :: ForeignHValue
                  , subTerms  :: [Term] }
 
           | Prim { ty        :: RttiType
-                 , value     :: [Word] }
+                 , valRaw    :: [Word] }
 
           | Suspension { ctype    :: ClosureType
                        , ty       :: RttiType
-                       , val      :: HValue
+                       , val      :: ForeignHValue
                        , bound_to :: Maybe Name   -- Useful for printing
                        }
           | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
@@ -99,22 +106,6 @@ data Term = Term { ty        :: RttiType
                          ty           :: RttiType
                        , wrapped_term :: Term }
 
-isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
-isTerm Term{} = True
-isTerm   _    = False
-isSuspension Suspension{} = True
-isSuspension      _       = False
-isPrim Prim{} = True
-isPrim   _    = False
-isNewtypeWrap NewtypeWrap{} = True
-isNewtypeWrap _             = False
-
-isFun Suspension{ctype=Fun} = True
-isFun _ = False
-
-isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
-isFunLike _ = False
-
 termType :: Term -> RttiType
 termType t = ty t
 
@@ -129,122 +120,33 @@ instance Outputable (Term) where
  ppr t | Just doc <- cPprTerm cPprTermBase t = doc
        | otherwise = panic "Outputable Term instance"
 
--------------------------------------------------------------------------
--- Runtime Closure Datatype and functions for retrieving closure related stuff
--------------------------------------------------------------------------
-data ClosureType = Constr
-                 | Fun
-                 | Thunk Int
-                 | ThunkSelector
-                 | Blackhole
-                 | AP
-                 | PAP
-                 | Indirection Int
-                 | MutVar Int
-                 | MVar   Int
-                 | Other  Int
- deriving (Show, Eq)
-
-data Closure = Closure { tipe         :: ClosureType
-                       , infoPtr      :: Ptr ()
-                       , infoTable    :: StgInfoTable
-                       , ptrs         :: Array Int HValue
-                       , nonPtrs      :: [Word]
-                       }
+----------------------------------------
+-- Runtime Closure information functions
+----------------------------------------
 
-instance Outputable ClosureType where
-  ppr = text . show
-
-#include "../includes/rts/storage/ClosureTypes.h"
-
-aP_CODE, pAP_CODE :: Int
-aP_CODE = AP
-pAP_CODE = PAP
-#undef AP
-#undef PAP
-
-getClosureData :: DynFlags -> a -> IO Closure
-getClosureData dflags a =
-   case unpackClosure# a of
-     (# iptr, ptrs, nptrs #) -> do
-           let iptr0 = Ptr iptr
-           let iptr1
-                | ghciTablesNextToCode = iptr0
-                | otherwise =
-                   -- the info pointer we get back from unpackClosure#
-                   -- is to the beginning of the standard info table,
-                   -- but the Storable instance for info tables takes
-                   -- into account the extra entry pointer when
-                   -- !ghciTablesNextToCode, so we must adjust here:
-                   iptr0 `plusPtr` negate (wORD_SIZE dflags)
-           itbl <- peekItbl iptr1
-           let tipe = readCType (InfoTable.tipe itbl)
-               elems = fromIntegral (InfoTable.ptrs itbl)
-               ptrsList = Array 0 (elems - 1) elems ptrs
-               nptrs_data = [W# (indexWordArray# nptrs i)
-                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
-           ASSERT(elems >= 0) return ()
-           ptrsList `seq`
-            return (Closure tipe iptr0 itbl ptrsList nptrs_data)
-
-readCType :: Integral a => a -> ClosureType
-readCType i
- | i >= CONSTR && i <= CONSTR_NOCAF        = Constr
- | i >= FUN    && i <= FUN_STATIC          = Fun
- | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
- | i == THUNK_SELECTOR                     = ThunkSelector
- | i == BLACKHOLE                          = Blackhole
- | i >= IND    && i <= IND_STATIC          = Indirection i'
- | i' == aP_CODE                           = AP
- | i == AP_STACK                           = AP
- | i' == pAP_CODE                          = PAP
- | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
- | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
- | otherwise                               = Other  i'
-  where i' = fromIntegral i
-
-isConstr, isIndirection, isThunk :: ClosureType -> Bool
-isConstr Constr = True
-isConstr    _   = False
-
-isIndirection (Indirection _) = True
-isIndirection _ = False
-
-isThunk (Thunk _)     = True
-isThunk ThunkSelector = True
-isThunk AP            = True
+isThunk :: GenClosure a -> Bool
+isThunk ThunkClosure{} = True
+isThunk APClosure{} = True
+isThunk APStackClosure{} = True
 isThunk _             = False
 
-isFullyEvaluated :: DynFlags -> a -> IO Bool
-isFullyEvaluated dflags a = do
-  closure <- getClosureData dflags a
-  case tipe closure of
-    Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)
-                 return$ and are_subs_evaluated
-    _      -> return False
-  where amapM f = sequence . amap' f
-
--- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
-{-
-unsafeDeepSeq :: a -> b -> b
-unsafeDeepSeq = unsafeDeepSeq1 2
- where unsafeDeepSeq1 0 a b = seq a $! b
-       unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
-        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
-     -- | unsafePerformIO (isFullyEvaluated a) = b
-        | otherwise = case unsafePerformIO (getClosureData a) of
-                        closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
-        where tipe = unsafePerformIO (getClosureType a)
--}
+-- Lookup the name in a constructor closure
+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
+   let occName = mkOccName OccName.dataName occ
+       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
+   Right `fmap` lookupOrigIO hsc_env modName occName
+constrClosToName _hsc_env clos =
+   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
 
 -----------------------------------
 -- * Traversals for Terms
 -----------------------------------
-type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
 
 data TermFold a = TermFold { fTerm        :: TermProcessor a a
                            , fPrim        :: RttiType -> [Word] -> a
-                           , fSuspension  :: ClosureType -> RttiType -> HValue
+                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue
                                             -> Maybe Name -> a
                            , fNewtypeWrap :: RttiType -> Either String DataCon
                                             -> a -> a
@@ -255,7 +157,7 @@ data TermFold a = TermFold { fTerm        :: TermProcessor a a
 data TermFoldM m a =
                    TermFoldM {fTermM        :: TermProcessor a (m a)
                             , fPrimM        :: RttiType -> [Word] -> m a
-                            , fSuspensionM  :: ClosureType -> RttiType -> HValue
+                            , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
                                              -> Maybe Name -> m a
                             , fNewtypeWrapM :: RttiType -> Either String DataCon
                                             -> a -> m a
@@ -318,7 +220,6 @@ termTyCoVars = foldTerm TermFold {
 ----------------------------------
 
 type Precedence        = Int
-type TermPrinter       = Precedence -> Term ->   SDoc
 type TermPrinterM m    = Precedence -> Term -> m SDoc
 
 app_prec,cons_prec, max_prec ::Int
@@ -326,10 +227,6 @@ max_prec  = 10
 app_prec  = max_prec
 cons_prec = 5 -- TODO Extract this info from GHC itself
 
-pprTerm :: TermPrinter -> TermPrinter
-pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
-pprTerm _ _ _ = panic "pprTerm"
-
 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
 
@@ -338,22 +235,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
   return $ cparen (not (null tt) && p >= app_prec)
                   (text dc_tag <+> pprDeeperList fsep tt_docs)
 
-ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
     <+> hsep (map (ppr_term1 True) tt)
 -} -- TODO Printing infix constructors properly
-  tt_docs' <- mapM (y app_prec) tt
-  return $ sdocWithPprDebug $ \dbg ->
-    -- Don't show the dictionary arguments to
-    -- constructors unless -dppr-debug is on
-    let tt_docs = if dbg
-           then tt_docs'
-           else dropList (dataConTheta dc) tt_docs'
-    in if null tt_docs
-      then ppr dc
-      else cparen (p >= app_prec) $
-             sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
+  = do { tt_docs' <- mapM (y app_prec) tt
+       ; return $ ifPprDebug (show_tm tt_docs')
+                             (show_tm (dropList (dataConTheta dc) tt_docs'))
+                  -- Don't show the dictionary arguments to
+                  -- constructors unless -dppr-debug is on
+       }
+  where
+    show_tm tt_docs
+      | null tt_docs = ppr dc
+      | otherwise    = cparen (p >= app_prec) $
+                       sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
 
 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 ppr_termM y p RefWrap{wrapped_term=t}  = do
@@ -368,10 +265,10 @@ ppr_termM _ _ t = ppr_termM1 t
 
 
 ppr_termM1 :: Monad m => Term -> m SDoc
-ppr_termM1 Prim{value=words, ty=ty} =
+ppr_termM1 Prim{valRaw=words, ty=ty} =
     return $ repPrim (tyConAppTyCon ty) words
 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
-    return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
+    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
 --  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
   | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
@@ -411,8 +308,10 @@ cPprTerm printers_ = go 0 where
   go prec t = do
     let default_ = Just `liftM` pprTermM go prec t
         mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
-    Just doc <- firstJustM mb_customDocs
-    return$ cparen (prec>app_prec+1) doc
+    mdoc <- firstJustM mb_customDocs
+    case mdoc of
+      Nothing -> panic "cPprTerm"
+      Just doc -> return $ cparen (prec>app_prec+1) doc
 
   firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
   firstJustM [] = return Nothing
@@ -425,19 +324,26 @@ cPprTermBase y =
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
            ppr_list
-  , ifTerm (isTyCon intTyCon    . ty) ppr_int
-  , ifTerm (isTyCon charTyCon   . ty) ppr_char
-  , ifTerm (isTyCon floatTyCon  . ty) ppr_float
-  , ifTerm (isTyCon doubleTyCon . ty) ppr_double
-  , ifTerm (isIntegerTy         . ty) ppr_integer
+  , ifTerm' (isTyCon intTyCon    . ty) ppr_int
+  , ifTerm' (isTyCon charTyCon   . ty) ppr_char
+  , ifTerm' (isTyCon floatTyCon  . ty) ppr_float
+  , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
+#if defined(INTEGER_GMP)
+  , ifTerm' (isIntegerTy         . ty) ppr_integer
+#endif
   ]
  where
    ifTerm :: (Term -> Bool)
           -> (Precedence -> Term -> m SDoc)
           -> Precedence -> Term -> m (Maybe SDoc)
-   ifTerm pred f prec t@Term{}
-       | pred t    = Just `liftM` f prec t
-   ifTerm _ _ _ _  = return Nothing
+   ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
+
+   ifTerm' :: (Term -> Bool)
+          -> (Precedence -> Term -> m (Maybe SDoc))
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm' pred f prec t@Term{}
+       | pred t    = f prec t
+   ifTerm' _ _ _ _  = return Nothing
 
    isTupleTy ty    = fromMaybe False $ do
      (tc,_) <- tcSplitTyConApp_maybe ty
@@ -451,13 +357,67 @@ cPprTermBase y =
      (tc,_) <- tcSplitTyConApp_maybe ty
      return (tyConName tc == integerTyConName)
 
-   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
-      :: Precedence -> Term -> m SDoc
-   ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
-   ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
-   ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))
-   ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))
-   ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+   ppr_int, ppr_char, ppr_float, ppr_double
+      :: Precedence -> Term -> m (Maybe SDoc)
+   ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.int (fromIntegral w)))
+   ppr_int _ _ = return Nothing
+
+   ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
+   ppr_char _ _ = return Nothing
+
+   ppr_float   _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.float f))
+   ppr_float _ _ = return Nothing
+
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.double f))
+   -- let's assume that if we get two words, we're on a 32-bit
+   -- machine. There's no good way to get a DynFlags to check the word
+   -- size here.
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> do
+                  poke p (fromIntegral w1 :: Word32)
+                  poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
+                  peek (castPtr p)
+      return (Just (Ppr.double f))
+   ppr_double _ _ = return Nothing
+
+   ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
+#if defined(INTEGER_GMP)
+   -- Reconstructing Integers is a bit of a pain. This depends deeply
+   -- on the integer-gmp representation, so it'll break if that
+   -- changes (but there are several tests in
+   -- tests/ghci.debugger/scripts that will tell us if this is wrong).
+   --
+   --   data Integer
+   --     = S# Int#
+   --     | Jp# {-# UNPACK #-} !BigNat
+   --     | Jn# {-# UNPACK #-} !BigNat
+   --
+   --   data BigNat = BN# ByteArray#
+   --
+   ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
+      return (Just (Ppr.integer (S# (word2Int# w))))
+   ppr_integer _ Term{dc=Right con,
+                      subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
+      -- We don't need to worry about sizes that are not an integral
+      -- number of words, because luckily GMP uses arrays of words
+      -- (see GMP_LIMB_SHIFT).
+      let
+        !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
+        constr
+          | "Jp#" <- occNameString (nameOccName (dataConName con)) = Jp#
+          | otherwise = Jn#
+      return (Just (Ppr.integer (constr (BN# arr#))))
+#endif
+   ppr_integer _ _ = return Nothing
 
    --Note pprinting of list terms is not lazy
    ppr_list :: Precedence -> Term -> m SDoc
@@ -465,10 +425,12 @@ cPprTermBase y =
        let elems      = h : getListTerms t
            isConsLast = not (termType (last elems) `eqType` termType h)
            is_string  = all (isCharTy . ty) elems
+           chars = [ chr (fromIntegral w)
+                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
 
        print_elems <- mapM (y cons_prec) elems
        if is_string
-        then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+        then return (Ppr.doubleQuotes (Ppr.text chars))
         else if isConsLast
         then return $ cparen (p >= cons_prec)
                     $ pprDeeperList fsep
@@ -487,7 +449,9 @@ cPprTermBase y =
 repPrim :: TyCon -> [Word] -> SDoc
 repPrim t = rep where
    rep x
-    | t == charPrimTyCon             = text $ show (build x :: Char)
+    -- Char# uses native machine words, whereas Char's Storable instance uses
+    -- Int32, so we have to read it as an Int.
+    | t == charPrimTyCon             = text $ show (chr (build x :: Int))
     | t == intPrimTyCon              = text $ show (build x :: Int)
     | t == wordPrimTyCon             = text $ show (build x :: Word)
     | t == floatPrimTyCon            = text $ show (build x :: Float)
@@ -637,13 +601,30 @@ addConstraint actual expected = do
       discardResult $
       captureConstraints $
       do { (ty1, ty2) <- congruenceNewtypes actual expected
-         ; unifyType noThing ty1 ty2 }
+         ; unifyType Nothing ty1 ty2 }
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
--- Type & Term reconstruction
-------------------------------
-cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
+
+-- | Term reconstruction
+--
+-- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
+-- representation of the object. Subterms (objects in the payload) are also
+-- built up to the given `max_depth`. After `max_depth` any subterms will appear
+-- as `Suspension`s. Any thunks found while traversing the object will be forced
+-- based on `force` parameter.
+--
+-- Types of terms will be refined based on constructors we find during term
+-- reconstruction. See `cvReconstructType` for an overview of how type
+-- reconstruction works.
+--
+cvObtainTerm
+    :: HscEnv
+    -> Int      -- ^ How many times to recurse for subterms
+    -> Bool     -- ^ Force thunks
+    -> RttiType -- ^ Type of the object to reconstruct
+    -> ForeignHValue   -- ^ Object to reconstruct
+    -> IO Term
 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
   -- we quantify existential tyvars as universal,
   -- as this is needed to be able to manipulate
@@ -688,9 +669,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             text "Type obtained: " <> ppr (termType term))
    return term
     where
-  dflags = hsc_dflags hsc_env
-
-  go :: Int -> Type -> Type -> HValue -> TcM Term
+  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
    -- I believe that my_ty should not have any enclosing
    -- foralls, nor any free RuntimeUnk skolems;
    -- that is partly what the quantifyType stuff achieved
@@ -700,27 +679,32 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
   go 0 my_ty _old_ty a = do
     traceTR (text "Gave up reconstructing a term after" <>
                   int max_depth <> text " steps")
-    clos <- trIO $ getClosureData dflags a
-    return (Suspension (tipe clos) my_ty a Nothing)
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    return (Suspension (tipe (info clos)) my_ty a Nothing)
   go !max_depth my_ty old_ty a = do
     let monomorphic = not(isTyVarTy my_ty)
     -- This ^^^ is a convention. The ancestor tests for
     -- monomorphism and passes a type instead of a tv
-    clos <- trIO $ getClosureData dflags a
-    case tipe clos of
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
 -- Thunks we may want to force
-      t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
-                                seq a (go (pred max_depth) my_ty old_ty a)
+      t | isThunk t && force -> do
+         traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
+         liftIO $ GHCi.seqHValue hsc_env a
+         go (pred max_depth) my_ty old_ty a
 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we
 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
 -- showing '_' which is what we want.
-      Blackhole -> do traceTR (text "Following a BLACKHOLE")
-                      appArr (go max_depth my_ty old_ty) (ptrs clos) 0
+      BlackholeClosure{indirectee=ind} -> do
+         traceTR (text "Following a BLACKHOLE")
+         go max_depth my_ty old_ty ind
 -- We always follow indirections
-      Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
-                          go max_depth my_ty old_ty $! (ptrs clos ! 0)
+      IndClosure{indirectee=ind} -> do
+         traceTR (text "Following an indirection" )
+         go max_depth my_ty old_ty ind
 -- We also follow references
-      MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+      MutVarClosure{var=contents}
+         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
              -> do
                   -- Deal with the MutVar# primitive
                   -- It does not have a constructor at all,
@@ -728,8 +712,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                   -- MutVar# :: contents_ty -> MutVar# s contents_ty
          traceTR (text "Following a MutVar")
          contents_tv <- newVar liftedTypeKind
-         contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
-         ASSERT(isUnliftedType my_ty) return ()
+         MASSERT(isUnliftedType my_ty)
          (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
                             contents_ty (mkTyConApp tycon [world,contents_ty])
          addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
@@ -737,12 +720,12 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
          return (RefWrap my_ty x)
 
  -- The interesting case
-      Constr -> do
-        traceTR (text "entering a constructor " <>
+      ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
+        traceTR (text "entering a constructor " <> ppr dArgs <+>
                       if monomorphic
                         then parens (text "already monomorphic: " <> ppr my_ty)
                         else Ppr.empty)
-        Right dcname <- dataConInfoPtrToName (infoPtr clos)
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
         (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing -> do -- This can happen for private constructors compiled -O0
@@ -753,10 +736,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                        traceTR (text "Not constructor" <+> ppr dcname)
                        let dflags = hsc_dflags hsc_env
                            tag = showPpr dflags dcname
-                       vars     <- replicateM (length$ elems$ ptrs clos)
+                       vars     <- replicateM (length pArgs)
                                               (newVar liftedTypeKind)
-                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
-                                              | (i, tv) <- zip [0..] vars]
+                       subTerms <- sequence $ zipWith (\x tv ->
+                           go (pred max_depth) tv tv x) pArgs vars
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
             traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
@@ -764,10 +747,18 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
             return (Term my_ty (Right dc) a subTerms)
 
+      -- This is to support printing of Integers. It's not a general
+      -- mechanism by any means; in particular we lose the size in
+      -- bytes of the array.
+      ArrWordsClosure{bytes=b, arrWords=ws} -> do
+         traceTR (text "ByteArray# closure, size " <> ppr b)
+         return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
+
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
-      tipe_clos -> do
-         traceTR (text "Unknown closure:" <+> ppr tipe_clos)
-         return (Suspension tipe_clos my_ty a Nothing)
+      _ -> do
+         traceTR (text "Unknown closure:" <+>
+                  text (show (fmap (const ()) clos)))
+         return (Suspension (tipe (info clos)) my_ty a Nothing)
 
   -- insert NewtypeWraps around newtypes
   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
@@ -786,53 +777,118 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
                           | otherwise  = Suspension ct ty hval n
 
-extractSubTerms :: (Type -> HValue -> TcM Term)
-                -> Closure -> [Type] -> TcM [Term]
-extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
+extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thdOf3 . go 0 0
   where
-    go ptr_i ws [] = return (ptr_i, ws, [])
-    go ptr_i ws (ty:tys)
+    array = dataArgs clos
+
+    go ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go ptr_i arr_i (ty:tys)
       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
       , isUnboxedTupleTyCon tc
                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
-           (ptr_i, ws, terms1) <- go ptr_i ws tys
-           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+      = do (ptr_i, arr_i, terms0) <-
+               go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
       = case typePrimRepArgs ty of
           [rep_ty] ->  do
-            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty
-            (ptr_i, ws, terms1) <- go ptr_i ws tys
-            return (ptr_i, ws, term0 : terms1)
+            (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i ty rep_ty
+            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+            return (ptr_i, arr_i, term0 : terms1)
           rep_tys -> do
-           (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
-           (ptr_i, ws, terms1) <- go ptr_i ws tys
-           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+           (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
 
-    go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
-    go_unary_types ptr_i ws (rep_ty:rep_tys) = do
+    go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
       tv <- newVar liftedTypeKind
-      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep_ty
-      (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
-      return (ptr_i, ws, term0 : terms1)
-
-    go_rep ptr_i ws ty rep
-      | isGcPtrRep rep
-      = do t <- appArr (recurse ty) (ptrs clos) ptr_i
-           return (ptr_i + 1, ws, t)
-      | otherwise
-      = do dflags <- getDynFlags
-           let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
-           return (ptr_i, ws1, Prim ty ws0)
+      (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i tv rep_ty
+      (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
+      return (ptr_i, arr_i, term0 : terms1)
+
+    go_rep ptr_i arr_i ty rep
+      | isGcPtrRep rep = do
+          t <- recurse ty $ (ptrArgs clos)!!ptr_i
+          return (ptr_i + 1, arr_i, t)
+      | otherwise = do
+          -- This is a bit involved since we allow packing multiple fields
+          -- within a single word. See also
+          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
+          dflags <- getDynFlags
+          let word_size = wORD_SIZE dflags
+              big_endian = wORDS_BIGENDIAN dflags
+              size_b = primRepSizeB dflags rep
+              -- Align the start offset (eg, 2-byte value should be 2-byte
+              -- aligned). But not more than to a word. The offset calculation
+              -- should be the same with the offset calculation in
+              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
+              !aligned_idx = roundUpTo arr_i (min word_size size_b)
+              !new_arr_i = aligned_idx + size_b
+              ws | size_b < word_size =
+                     [index size_b aligned_idx word_size big_endian]
+                 | otherwise =
+                     let (q, r) = size_b `quotRem` word_size
+                     in ASSERT( r == 0 )
+                        [ array!!i
+                        | o <- [0.. q - 1]
+                        , let i = (aligned_idx `quot` word_size) + o
+                        ]
+          return (ptr_i, new_arr_i, Prim ty ws)
 
     unboxedTupleTerm ty terms
       = Term ty (Right (tupleDataCon Unboxed (length terms)))
                 (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
 
-
--- Fast, breadth-first Type reconstruction
-------------------------------------------
-cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
+    -- Extract a sub-word sized field from a word
+    index item_size_b index_b word_size big_endian =
+        (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
+      where
+        mask :: Word
+        mask = case item_size_b of
+            1 -> 0xFF
+            2 -> 0xFFFF
+            4 -> 0xFFFFFFFF
+            _ -> panic ("Weird byte-index: " ++ show index_b)
+        (q,r) = index_b `quotRem` word_size
+        word = array!!q
+        moveBytes = if big_endian
+                    then word_size - (r + item_size_b) * 8
+                    else r * 8
+
+
+-- | Fast, breadth-first Type reconstruction
+--
+-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
+-- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
+-- This is used for improving type information in debugger. For example, if we
+-- have a polymorphic function:
+--
+--     sumNumList :: Num a => [a] -> a
+--     sumNumList [] = 0
+--     sumNumList (x : xs) = x + sumList xs
+--
+-- and add a breakpoint to it:
+--
+--     ghci> break sumNumList
+--     ghci> sumNumList ([0 .. 9] :: [Int])
+--
+-- ghci shows us more precise types than just `a`s:
+--
+--     Stopped in Main.sumNumList, debugger.hs:3:23-39
+--     _result :: Int = _
+--     x :: Int = 0
+--     xs :: [Int] = _
+--
+cvReconstructType
+    :: HscEnv
+    -> Int       -- ^ How many times to recurse for subterms
+    -> GhciType  -- ^ Type to refine
+    -> ForeignHValue  -- ^ Refine the type using this value
+    -> IO (Maybe Type)
 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    traceTR (text "RTTI started with initial type " <> ppr old_ty)
    let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
@@ -860,8 +916,6 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
    return new_ty
     where
-  dflags = hsc_dflags hsc_env
-
 --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
                                 int max_depth <> text " steps")
@@ -873,35 +927,33 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
                   search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
 
    -- returns unification tasks,since we are going to want a breadth-first search
-  go :: Type -> HValue -> TR [(Type, HValue)]
+  go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
   go my_ty a = do
     traceTR (text "go" <+> ppr my_ty)
-    clos <- trIO $ getClosureData dflags a
-    case tipe clos of
-      Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
-      Indirection _ -> go my_ty $! (ptrs clos ! 0)
-      MutVar _ -> do
-         contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
+      BlackholeClosure{indirectee=ind} -> go my_ty ind
+      IndClosure{indirectee=ind} -> go my_ty ind
+      MutVarClosure{var=contents} -> do
          tv'   <- newVar liftedTypeKind
          world <- newVar liftedTypeKind
          addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
          return [(tv', contents)]
-      Constr -> do
-        Right dcname <- dataConInfoPtrToName (infoPtr clos)
+      ConstrClosure{ptrArgs=pArgs} -> do
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
         traceTR (text "Constr1" <+> ppr dcname)
-        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
+        (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
-            forM (elems $ ptrs clos) $ \a -> do
+            forM pArgs $ \x -> do
               tv <- newVar liftedTypeKind
-              return (tv, a)
+              return (tv, x)
 
           Just dc -> do
             arg_tys <- getDataConArgTys dc my_ty
             (_, itys) <- findPtrTyss 0 arg_tys
             traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
-            return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
-                     | (i,ty) <- itys]
+            return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
       _ -> return []
 
 findPtrTys :: Int  -- Current pointer index
@@ -950,6 +1002,9 @@ getDataConArgTys dc con_app_ty
   = do { let rep_con_app_ty = unwrapType con_app_ty
        ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
                    $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+       ; ASSERT( all isTyVar ex_tvs ) return ()
+                 -- ex_tvs can only be tyvars as data types in source
+                 -- Haskell cannot mention covar yet (Aug 2018)
        ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
        ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
               -- See Note [Constructor arg types]
@@ -958,7 +1013,7 @@ getDataConArgTys dc con_app_ty
        ; return con_arg_tys }
   where
     univ_tvs = dataConUnivTyVars dc
-    ex_tvs   = dataConExTyVars dc
+    ex_tvs   = dataConExTyCoVars dc
 
 {- Note [Constructor arg types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1186,7 +1241,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                (_, vars) <- instTyVars (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
                    rep_ty = unwrapType ty'
-               _ <- liftTcM (unifyType noThing ty rep_ty)
+               _ <- liftTcM (unifyType Nothing ty rep_ty)
         -- assumes that reptype doesn't ^^^^ touch tyconApp args
                return ty'
 
@@ -1205,17 +1260,9 @@ zonkTerm = foldTermM (TermFoldM
 
 zonkRttiType :: TcType -> TcM Type
 -- Zonk the type, replacing any unbound Meta tyvars
--- by skolems, safely out of Meta-tyvar-land
-zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
-  where
-    zonk_unbound_meta tv
-      = ASSERT( isTcTyVar tv )
-        do { tv' <- skolemiseRuntimeUnk tv
-             -- This is where RuntimeUnks are born:
-             -- otherwise-unconstrained unification variables are
-             -- turned into RuntimeUnks as they leave the
-             -- typechecker's monad
-           ; return (mkTyVarTy tv') }
+-- by RuntimeUnk skolems, safely out of Meta-tyvar-land
+zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi
+                    ; zonkTcTypeToTypeX ze ty }
 
 --------------------------------------------------------------------------------
 -- Restore Class predicates out of a representation type
@@ -1267,15 +1314,3 @@ quantifyType ty = ( filter isTyVar $
                   , rho)
   where
     (_tvs, rho) = tcSplitForAllTys ty
-
--- Strict application of f at index i
-appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
-appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
- = ASSERT2(i < length(elems a), ppr(length$ elems a, i))
-   case indexArray# ptrs# i# of
-       (# e #) -> f e
-
-amap' :: (t -> b) -> Array Int t -> [b]
-amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
-    where g (I# i#) = case indexArray# arr# i# of
-                          (# e #) -> f e
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index de36a85937..5d0f5afce1 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -8,13 +8,16 @@ This module converts Template Haskell syntax into HsSyn
 
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 convertToHsType,
                 thRdrNameGuesses ) where
 
+import GhcPrelude
+
 import HsSyn as Hs
-import qualified Class
+import PrelNames
 import RdrName
 import qualified Name
 import Module
@@ -25,7 +28,6 @@ import SrcLoc
 import Type
 import qualified Coercion ( Role(..) )
 import TysWiredIn
-import TysPrim (eqPrimTyCon)
 import BasicTypes as Hs
 import ForeignCall
 import Unique
@@ -40,7 +42,7 @@ import MonadUtils ( foldrM )
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap, (<=<) )
 
-import Data.Maybe( catMaybes, fromMaybe, isNothing )
+import Data.Maybe( catMaybes, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
@@ -142,15 +144,15 @@ cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
         ; body' <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") ds
-        ; returnJustL $ Hs.ValD $
-          PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
-                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
+        ; returnJustL $ Hs.ValD noExt $
+          PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds')
+                  , pat_ext = noExt
                   , pat_ticks = ([],[]) } }
 
 cvtDec (TH.FunD nm cls)
@@ -161,12 +163,13 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType typ
-        ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
+        ; returnJustL $ Hs.SigD noExt
+                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
 
 cvtDec (TH.InfixD fx nm)
   -- Fixity signatures are allowed for variables, constructors, and types
@@ -174,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
   -- 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)))) }
+       ; returnJustL (Hs.SigD noExt (FixSig noExt
+                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
   = cvtPragmaD prag
@@ -182,10 +186,9 @@ cvtDec (PragmaD prag)
 cvtDec (TySynD tc tvs rhs)
   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
         ; rhs' <- cvtType rhs
-        ; returnJustL $ TyClD $
-          SynDecl { tcdLName = tc', tcdTyVars = tvs'
+        ; returnJustL $ TyClD noExt $
+          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
                   , tcdFixity = Prefix
-                  , tcdFVs = placeHolderNames
                   , tcdRhs = rhs' } }
 
 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
@@ -204,31 +207,33 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
         ; ksig' <- cvtKind `traverse` ksig
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = DataType, dd_cType = Nothing
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = cons', dd_derivs = derivs' }
-        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+        ; returnJustL $ TyClD noExt (DataDecl
+                                        { tcdDExt = noExt
+                                        , tcdLName = tc', tcdTyVars = tvs'
                                         , tcdFixity = Prefix
-                                        , tcdDataDefn = defn
-                                        , tcdDataCusk = PlaceHolder
-                                        , tcdFVs = placeHolderNames }) }
+                                        , tcdDataDefn = defn }) }
 
 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
         ; ksig' <- cvtKind `traverse` ksig
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = NewType, dd_cType = Nothing
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = [con']
                                 , dd_derivs = derivs' }
-        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
+        ; returnJustL $ TyClD noExt (DataDecl
+                                    { tcdDExt = noExt
+                                    , tcdLName = tc', tcdTyVars = tvs'
                                     , tcdFixity = Prefix
-                                    , tcdDataDefn = defn
-                                    , tcdDataCusk = PlaceHolder
-                                    , tcdFVs = placeHolderNames }) }
+                                    , tcdDataDefn = defn }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
   = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
@@ -239,13 +244,13 @@ cvtDec (ClassD ctxt cl tvs fds decs)
                      <+> text "are not allowed:")
                    $$ (Outputable.ppr adts'))
         ; at_defs <- mapM cvt_at_def ats'
-        ; returnJustL $ TyClD $
-          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+        ; returnJustL $ TyClD noExt $
+          ClassDecl { tcdCExt = noExt
+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
                     , tcdFixity = Prefix
                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                     , tcdMeths = binds'
-                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
-                    , tcdFVs = placeHolderNames }
+                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
                               -- no docs in TH ^^
         }
   where
@@ -262,8 +267,8 @@ cvtDec (InstanceD o ctxt ty decs)
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
         ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
-        ; returnJustL $ InstD $ ClsInstD $
-          ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
+        ; returnJustL $ InstD noExt $ ClsInstD noExt $
+          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
                       , cid_binds = binds'
                       , cid_sigs = Hs.mkClassOpSigs sigs'
                       , cid_tyfam_insts = ats', cid_datafam_insts = adts'
@@ -281,97 +286,107 @@ cvtDec (InstanceD o ctxt ty decs)
 
 cvtDec (ForeignD ford)
   = do { ford' <- cvtForD ford
-       ; returnJustL $ ForD ford' }
+       ; returnJustL $ ForD noExt ford' }
 
 cvtDec (DataFamilyD tc tvs kind)
   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; result <- cvtMaybeKindToFamilyResultSig kind
-       ; returnJustL $ TyClD $ FamDecl $
-         FamilyDecl DataFamily tc' tvs' Prefix result Nothing }
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
 
 cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; ksig' <- cvtKind `traverse` ksig
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = cons', dd_derivs = derivs' }
 
-       ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn
-                                         , dfid_fixity = Prefix
-                                         , dfid_fvs = placeHolderNames } }}
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
 
 cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; ksig' <- cvtKind `traverse` ksig
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
-       ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn
-                                         , dfid_fixity = Prefix
-                                         , dfid_fvs = placeHolderNames } }}
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
-        ; eqn' <- cvtTySynEqn tc' eqn
-        ; returnJustL $ InstD $ TyFamInstD
-            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
-                                        , tfid_fvs = placeHolderNames } } }
+        ; L _ eqn' <- cvtTySynEqn tc' eqn
+        ; returnJustL $ InstD noExt $ TyFamInstD
+            { tfid_ext = noExt
+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
 
 cvtDec (OpenTypeFamilyD head)
   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
-       ; returnJustL $ TyClD $ FamDecl $
-         FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
+       }
 
 cvtDec (ClosedTypeFamilyD head eqns)
   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
        ; eqns' <- mapM (cvtTySynEqn tc') eqns
-       ; returnJustL $ TyClD $ FamDecl $
-         FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
-                                      injectivity' }
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
+                           result' injectivity' }
 
 cvtDec (TH.RoleAnnotD tc roles)
   = do { tc' <- tconNameL tc
        ; let roles' = map (noLoc . cvtRole) roles
-       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
+       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
 
 cvtDec (TH.StandaloneDerivD ds cxt ty)
   = do { cxt' <- cvtContext cxt
+       ; ds'  <- traverse cvtDerivStrategy ds
        ; L loc ty'  <- cvtType ty
        ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
-       ; returnJustL $ DerivD $
-         DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
-                   , deriv_type = mkLHsSigType inst_ty'
+       ; returnJustL $ DerivD noExt $
+         DerivDecl { deriv_ext =noExt
+                   , deriv_strategy = ds'
+                   , deriv_type = mkLHsSigWcType inst_ty'
                    , deriv_overlap_mode = Nothing } }
 
 cvtDec (TH.DefaultSigD nm typ)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType typ
-       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
+       ; returnJustL $ Hs.SigD noExt
+                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
 
 cvtDec (TH.PatSynD nm args dir pat)
   = do { nm'   <- cNameL nm
        ; args' <- cvtArgs args
        ; dir'  <- cvtDir nm' dir
        ; pat'  <- cvtPat pat
-       ; returnJustL $ Hs.ValD $ PatSynBind $
-           PSB nm' placeHolderType args' pat' dir' }
+       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
+           PSB noExt nm' args' pat' dir' }
   where
-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
     cvtArgs (TH.RecordPatSyn sels)
       = do { sels' <- mapM vNameL sels
            ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
-           ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
 
     cvtDir _ Unidir          = return Unidirectional
     cvtDir _ ImplBidir       = return ImplicitBidirectional
@@ -382,17 +397,25 @@ cvtDec (TH.PatSynD nm args dir pat)
 cvtDec (TH.PatSynSigD nm ty)
   = do { nm' <- cNameL nm
        ; ty' <- cvtPatSynSigTy ty
-       ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
+       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
+
+-- Implicit parameter bindings are handled in cvtLocalDecs and
+-- cvtImplicitParamBind. They are not allowed in any other scope, so
+-- reaching this case indicates an error.
+cvtDec (TH.ImplicitParamBindD _ _)
+  = failWith (text "Implicit parameter binding only allowed in let or where")
 
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
 cvtTySynEqn tc (TySynEqn lhs rhs)
   = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs
         ; rhs' <- cvtType rhs
-        ; returnL $ TyFamEqn { tfe_tycon = tc
-                             , tfe_pats = mkHsImplicitBndrs lhs'
-                             , tfe_fixity = Prefix
-                             , tfe_rhs = rhs' } }
+        ; returnL $ mkHsImplicitBndrs
+                  $ FamEqn { feqn_ext    = noExt
+                           , feqn_tycon  = tc
+                           , feqn_pats   = lhs'
+                           , feqn_fixity = Prefix
+                           , feqn_rhs    = rhs' } }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -430,12 +453,12 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext GhcPs
                        , Located RdrName
-                       , HsImplicitBndrs GhcPs [LHsType GhcPs])
+                       , HsTyPats GhcPs)
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tys' <- mapM (wrap_apps <=< cvtType) tys
-       ; return (cxt', tc', mkHsImplicitBndrs tys') }
+       ; return (cxt', tc', tys') }
 
 ----------------
 cvt_tyfam_head :: TypeFamilyHead
@@ -455,25 +478,33 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
 -------------------------------------------------------------------
 
 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
+is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
 is_fam_decl decl = Right decl
 
 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
-is_tyfam_inst decl                                              = Right decl
+is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+  = Left (L loc d)
+is_tyfam_inst decl
+  = Right decl
 
 is_datafam_inst :: LHsDecl GhcPs
                 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
-is_datafam_inst decl                                                = Right decl
+is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
+  = Left (L loc d)
+is_datafam_inst decl
+  = Right decl
 
 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
-is_sig decl                  = Right decl
+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
+is_sig decl                    = Right decl
 
 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
-is_bind decl                   = Right decl
+is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
+is_bind decl                     = Right decl
+
+is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
+is_ip_bind decl             = Right decl
 
 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
 mkBadDecMsg doc bads
@@ -488,59 +519,60 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
 
 cvtConstr (NormalC c strtys)
   = do  { c'   <- cNameL c
-        ; cxt' <- returnL []
         ; tys' <- mapM cvt_arg strtys
-        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
 
 cvtConstr (RecC c varstrtys)
   = do  { c'    <- cNameL c
-        ; cxt'  <- returnL []
         ; args' <- mapM cvt_id_arg varstrtys
-        ; returnL $ mkConDeclH98 c' Nothing cxt'
+        ; returnL $ mkConDeclH98 c' Nothing Nothing
                                    (RecCon (noLoc args')) }
 
 cvtConstr (InfixC st1 c st2)
   = do  { c'   <- cNameL c
-        ; cxt' <- returnL []
         ; st1' <- cvt_arg st1
         ; st2' <- cvt_arg st2
-        ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
 
 cvtConstr (ForallC tvs ctxt con)
-  = do  { tvs'        <- cvtTvs tvs
-        ; L loc ctxt' <- cvtContext ctxt
-        ; L _ con'    <- cvtConstr con
-        ; returnL $ case con' of
-                ConDeclGADT { con_type = conT } ->
-                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
-                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
-                                                         (hsib_body conT)
-                  in con' { con_type = mkHsImplicitBndrs hs_ty }
-                ConDeclH98  {} ->
-                  let qvars = case (tvs, con_qvars con') of
-                        ([], Nothing) -> Nothing
-                        (_ , m_qvs  ) -> Just $
-                          mkHsQTvs (hsQTvExplicit tvs' ++
-                                    maybe [] hsQTvExplicit m_qvs)
-                  in con' { con_qvars = qvars
-                          , con_cxt = Just $
-                            L loc (ctxt' ++
-                                   unLoc (fromMaybe (noLoc [])
-                                          (con_cxt con'))) } }
+  = do  { tvs'      <- cvtTvs tvs
+        ; ctxt'     <- cvtContext ctxt
+        ; L _ con'  <- cvtConstr con
+        ; returnL $ add_forall tvs' ctxt' con' }
+  where
+    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2))
+
+    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_qvars  = mkHsQTvs all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
+
+    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_ex_tvs = all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
+
+    add_forall _ _ (XConDecl _) = panic "cvtConstr"
 
 cvtConstr (GadtC c strtys ty)
   = do  { c'      <- mapM cNameL c
         ; args    <- mapM cvt_arg strtys
         ; L _ ty' <- cvtType ty
         ; c_ty    <- mk_arr_apps args ty'
-        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
+        ; returnL $ fst $ mkGadtDecl c' c_ty}
 
 cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
-        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
-        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
+        ; let rec_ty = noLoc (HsFunTy noExt
+                                           (noLoc $ HsRecTy noExt rec_flds) ty')
+        ; returnL $ fst $ mkGadtDecl c' rec_ty }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
@@ -558,15 +590,16 @@ cvt_arg (Bang su ss, ty)
        ; ty' <- wrap_apps ty''
        ; let su' = cvtSrcUnpackedness su
        ; let ss' = cvtSrcStrictness ss
-       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
+       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
 
 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
 cvt_id_arg (i, str, ty)
   = do  { L li i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField
-                          { cd_fld_names
-                              = [L li $ FieldOcc (L li i') PlaceHolder]
+                          { cd_fld_ext = noExt
+                          , cd_fld_names
+                              = [L li $ FieldOcc noExt (L li i')]
                           , cd_fld_type =  ty'
                           , cd_fld_doc = Nothing}) }
 
@@ -574,7 +607,7 @@ cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
 cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
                   ; returnL cs' }
 
-cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
+cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
                                ; ys' <- mapM tNameL ys
                                ; returnL (xs', ys') }
@@ -604,9 +637,9 @@ cvtForD (ImportF callconv safety from nm ty)
     mk_imp impspec
       = do { nm' <- vNameL nm
            ; ty' <- cvtType ty
-           ; return (ForeignImport { fd_name = nm'
+           ; return (ForeignImport { fd_i_ext = noExt
+                                   , fd_name = nm'
                                    , fd_sig_ty = mkLHsSigType ty'
-                                   , fd_co = noForeignImportCoercionYet
                                    , fd_fi = impspec })
            }
     safety' = case safety of
@@ -621,9 +654,9 @@ cvtForD (ExportF callconv as nm ty)
                                                 (mkFastString as)
                                                 (cvt_conv callconv)))
                                                 (noLoc (SourceText as))
-        ; return $ ForeignExport { fd_name = nm'
+        ; return $ ForeignExport { fd_e_ext = noExt
+                                 , fd_name = nm'
                                  , fd_sig_ty = mkLHsSigType ty'
-                                 , fd_co = noForeignExportCoercionYet
                                  , fd_fe = e } }
 
 cvt_conv :: TH.Callconv -> CCallConv
@@ -649,7 +682,7 @@ cvtPragmaD (InlineP nm inline rm phases)
                                  , inl_rule   = cvtRuleMatch rm
                                  , inl_act    = cvtPhases phases dflt
                                  , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
+       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }
 
 cvtPragmaD (SpecialiseP nm ty inline phases)
   = do { nm' <- vNameL nm
@@ -660,19 +693,19 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
        ; let (inline', dflt,srcText) = case inline of
                Just inline1 -> (cvtInline inline1, dfltActivation inline1,
                                 src inline1)
-               Nothing      -> (EmptyInlineSpec,   AlwaysActive,
+               Nothing      -> (NoUserInline,   AlwaysActive,
                                 "{-# SPECIALISE")
        ; let ip = InlinePragma { inl_src    = SourceText srcText
                                , inl_inline = inline'
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
                                , inl_sat    = Nothing }
-       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
+       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
 
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
-       ; returnJustL $ Hs.SigD $
-         SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+       ; returnJustL $ Hs.SigD noExt $
+         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
 
 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
@@ -680,11 +713,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; bndrs' <- mapM cvtRuleBndr bndrs
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
-       ; returnJustL $ Hs.RuleD
-            $ HsRules (SourceText "{-# RULES")
-                      [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
-                                                  lhs' placeHolderNames
-                                                  rhs' placeHolderNames]
+       ; returnJustL $ Hs.RuleD noExt
+            $ HsRules noExt (SourceText "{-# RULES")
+                      [noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
+                                                  act bndrs' lhs' rhs']
        }
 
 cvtPragmaD (AnnP target exp)
@@ -697,8 +729,8 @@ cvtPragmaD (AnnP target exp)
          ValueAnnotation n -> do
            n' <- vcName n
            return (ValueAnnProvenance (noLoc n'))
-       ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
-                                               exp'
+       ; returnJustL $ Hs.AnnD noExt
+                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
        }
 
 cvtPragmaD (LineP line file)
@@ -708,8 +740,8 @@ cvtPragmaD (LineP line file)
 cvtPragmaD (CompleteP cls mty)
   = do { cls' <- noLoc <$> mapM cNameL cls
        ; mty'  <- traverse tconNameL mty
-       ; returnJustL $ Hs.SigD
-                   $ CompleteMatchSig NoSourceText cls' mty' }
+       ; returnJustL $ Hs.SigD noExt
+                   $ CompleteMatchSig noExt NoSourceText cls' mty' }
 
 dfltActivation :: TH.Inline -> Activation
 dfltActivation TH.NoInline = NeverActive
@@ -732,11 +764,11 @@ cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
 cvtRuleBndr (RuleVar n)
   = do { n' <- vNameL n
-       ; return $ noLoc $ Hs.RuleBndr n' }
+       ; return $ noLoc $ Hs.RuleBndr noExt n' }
 cvtRuleBndr (TypedRuleVar n ty)
   = do { n'  <- vNameL n
        ; ty' <- cvtType ty
-       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
+       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }
 
 ---------------------------------------------------
 --              Declarations
@@ -744,25 +776,34 @@ cvtRuleBndr (TypedRuleVar n ty)
 
 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
 cvtLocalDecs doc ds
-  | null ds
-  = return EmptyLocalBinds
-  | otherwise
-  = do { ds' <- cvtDecs ds
-       ; let (binds, prob_sigs) = partitionWith is_bind ds'
-       ; let (sigs, bads) = partitionWith is_sig prob_sigs
-       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
+  = case partitionWith is_ip_bind ds of
+      ([], []) -> return (EmptyLocalBinds noExt)
+      ([], _) -> do
+        ds' <- cvtDecs ds
+        let (binds, prob_sigs) = partitionWith is_bind ds'
+        let (sigs, bads) = partitionWith is_sig prob_sigs
+        unless (null bads) (failWith (mkBadDecMsg doc bads))
+        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
+      (ip_binds, []) -> do
+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
+        return (HsIPBinds noExt (IPBinds noExt binds))
+      ((_:_), (_:_)) ->
+        failWith (text "Implicit parameters mixed with other bindings")
 
 cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
 cvtClause ctxt (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
-        ; pps <- mapM wrap_conpat ps'
+        ; let pps = map (parenthesizePat appPrec) ps'
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") wheres
-        ; returnL $ Hs.Match ctxt pps Nothing
-                             (GRHSs g' (noLoc ds')) }
+        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
 
+cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
+cvtImplicitParamBind n e = do
+    n' <- wrapL (ipName n)
+    e' <- cvtl e
+    returnL (IPBind noExt (Left n') e')
 
 -------------------------------------------------------------------
 --              Expressions
@@ -771,77 +812,105 @@ cvtClause ctxt (Clause ps body wheres)
 cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
 cvtl e = wrapL (cvt e)
   where
-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }
-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noLoc s') }
+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
     cvt (LitE l)
-      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
-      | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
+      | overloadedLit l = go cvtOverLit (HsOverLit noExt)
+                             (hsOverLitNeedsParens appPrec)
+      | otherwise       = go cvtLit (HsLit noExt)
+                             (hsLitNeedsParens appPrec)
+      where
+        go :: (Lit -> CvtM (l GhcPs))
+           -> (l GhcPs -> HsExpr GhcPs)
+           -> (l GhcPs -> Bool)
+           -> CvtM (HsExpr GhcPs)
+        go cvt_lit mk_expr is_compound_lit = do
+          l' <- cvt_lit l
+          let e' = mk_expr l'
+          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
     cvt (AppTypeE e t) = do { e' <- cvtl e
                             ; t' <- cvtType t
                             ; tp <- wrap_apps t'
-                            ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
+                            ; let tp' = parenthesizeHsType appPrec tp
+                            ; return $ HsAppType (mkHsWildCardBndrs tp') e' }
     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                                -- own expression to avoid pretty-printing
                                -- oddities that can result from zero-argument
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
-                            ; return $ HsLam (mkMatchGroup FromSource
-                                             [mkSimpleMatch LambdaExpr ps' e'])}
-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch LambdaExpr) ms
-                            ; return $ HsLamCase (mkMatchGroup FromSource ms')
+                            ; let pats = map (parenthesizePat appPrec) ps'
+                            ; return $ HsLam noExt (mkMatchGroup FromSource
+                                             [mkSimpleMatch LambdaExpr
+                                             pats e'])}
+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; return $ HsLamCase noExt
+                                                   (mkMatchGroup FromSource ms')
                             }
-    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
                                  -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es
-                            ; return $ ExplicitTuple (map (noLoc . Present) es')
-                                                      Boxed }
+                            ; return $ ExplicitTuple noExt
+                                             (map (noLoc . (Present noExt)) es')
+                                                                         Boxed }
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
-                                   ; return $ ExplicitTuple
-                                           (map (noLoc . Present) es') Unboxed }
+                                   ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) es')
+                                                                       Unboxed }
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                        ; unboxedSumChecks alt arity
-                                       ; return $ ExplicitSum
-                                             alt arity e' placeHolderType }
+                                       ; return $ ExplicitSum noExt
+                                                                   alt arity e'}
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
-                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
     cvt (MultiIfE alts)
       | null alts      = failWith (text "Multi-way if-expression with no alternatives")
       | otherwise      = do { alts' <- mapM cvtpair alts
-                            ; return $ HsMultiIf placeHolderType alts' }
+                            ; return $ HsMultiIf noExt alts' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
-                            ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
+                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
-                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
+                            ; return $ HsCase noExt e'
+                                                 (mkMatchGroup FromSource ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
-    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+                            ; return $ ArithSeq noExt Nothing dd' }
     cvt (ListE xs)
-      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
+                                          ; return (HsLit noExt l') }
              -- Note [Converting strings]
       | otherwise       = do { xs' <- mapM cvtl xs
-                             ; return $ ExplicitList placeHolderType Nothing xs'
+                             ; return $ ExplicitList noExt Nothing xs'
                              }
 
     -- Infix expressions
     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
-                                          ; wrapParL HsPar $
-                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
+                                          ; let px = parenthesizeHsExpr opPrec x'
+                                                py = parenthesizeHsExpr opPrec y'
+                                          ; wrapParL (HsPar noExt) $
+                                            OpApp noExt px s' py }
                                             -- Parenthesise both arguments and result,
                                             -- to ensure this operator application does
                                             -- does not get re-associated
                             -- See Note [Operator association]
     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
-                                          ; wrapParL HsPar $ SectionR s' y' }
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionR noExt s' y' }
                                             -- See Note [Sections in HsSyn] in HsExpr
     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
-                                          ; wrapParL HsPar $ SectionL x' s' }
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionL noExt x' s' }
 
-    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
+    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s
+                                          ; return $ HsPar noExt s' }
                                        -- Can I indicate this is an infix thing?
                                        -- Note [Dropping constructors]
 
@@ -851,9 +920,10 @@ cvtl e = wrapL (cvt e)
                                             _ -> mkLHsPar x'
                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
 
-    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
+    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
-                              ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
+                              ; let pe = parenthesizeHsExpr sigPrec e'
+                              ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -862,9 +932,14 @@ cvtl e = wrapL (cvt e)
                                   <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
                                            flds
                               ; return $ mkRdrRecordUpd e' flds' }
-    cvt (StaticE e)      = fmap (HsStatic placeHolderNames) $ cvtl e
-    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noLoc s') }
-    cvt (LabelE s)       = do { return $ HsOverLabel Nothing (fsLit s) }
+    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e
+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
+                              -- important, because UnboundVarE may contain
+                              -- constructor names - see #14627.
+                              { s' <- vcName s
+                              ; return $ HsVar noExt (noLoc s') }
+    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }
+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -914,7 +989,7 @@ the trees to reflect the fixities of the underlying operators:
 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
 right-biased for types and left-biased for everything else. So we left-bias the
-trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
 
 Sample input:
 
@@ -955,7 +1030,7 @@ cvtOpApp x op1 (UInfixE y op2 z)
 cvtOpApp x op y
   = do { op' <- cvtl op
        ; y' <- cvtl y
-       ; return (OpApp x op' undefined y') }
+       ; return (OpApp noExt x op' y') }
 
 -------------------------------------
 --      Do notation and statements
@@ -969,10 +1044,11 @@ cvtHsDo do_or_lc stmts
         ; let Just (stmts'', last') = snocView stmts'
 
         ; last'' <- case last' of
-                    L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
+                    L loc (BodyStmt _ body _ _)
+                      -> return (L loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
-        ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
+        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
   where
     bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
@@ -985,43 +1061,46 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
-                            ; returnL $ LetStmt (noLoc ds') }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
-                       where
-                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
+                            ; returnL $ LetStmt noExt (noLoc ds') }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
+                            ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }
+  where
+    cvt_one ds = do { ds' <- cvtStmts ds
+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
 
 cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
 cvtMatch ctxt (TH.Match p body decs)
   = do  { p' <- cvtPat p
-        ; lp <- case ctxt of
-            CaseAlt -> return p'
-            _       -> wrap_conpat p'
+        ; let lp = case p' of
+                     L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
+                     _              -> p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
-        ; returnL $ Hs.Match ctxt [lp] Nothing
-                             (GRHSs g' (noLoc decs')) }
+        ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
 
 cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
-cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
+cvtGuard (NormalB e)      = do { e' <- cvtl e
+                               ; g' <- returnL $ GRHS noExt [] e'; return [g'] }
 
 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
                               ; g' <- returnL $ mkBodyStmt ge'
-                              ; returnL $ GRHS [g'] rhs' }
+                              ; returnL $ GRHS noExt [g'] rhs' }
 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
-                              ; returnL $ GRHS gs' rhs' }
+                              ; returnL $ GRHS noExt gs' rhs' }
 
 cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral   (mkIntegralLit i)   placeHolderType}
+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
 cvtOverLit (RationalL r)
-  = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
-       ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
+       ; return $ mkHsIsString (quotedSourceText s) s'
        }
 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1052,9 +1131,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
 cvtLit (FloatPrimL f)
-  = do { force f; return $ HsFloatPrim def (mkFractionalLit f) }
+  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
 cvtLit (DoublePrimL f)
-  = do { force f; return $ HsDoublePrim def (mkFractionalLit f) }
+  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
 cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
 cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
@@ -1083,40 +1162,48 @@ cvtp (TH.LitP l)
                             ; return (mkNPat (noLoc l') Nothing) }
                                   -- Not right for negative patterns;
                                   -- need to think about that!
-  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
-cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
-cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }
-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s)       = do { s' <- vName s
+                            ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }
+                                         -- Note [Dropping constructors]
+cvtp (TupP ps)         = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Unboxed }
 cvtp (UnboxedSumP p alt arity)
                        = do { p' <- cvtPat p
                             ; unboxedSumChecks alt arity
-                            ; return $ SumPat p' alt arity placeHolderType }
+                            ; return $ SumPat noExt p' alt arity }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
-                            ; pps <- mapM wrap_conpat ps'
+                            ; let pps = map (parenthesizePat appPrec) ps'
                             ; return $ ConPatIn s' (PrefixCon pps) }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
-                            ; wrapParL ParPat $
-                              ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
+                            ; wrapParL (ParPat noExt) $
+                              ConPatIn s' $
+                              InfixCon (parenthesizePat opPrec p1')
+                                       (parenthesizePat opPrec p2') }
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
 cvtp (ParensP p)       = do { p' <- cvtPat p;
                             ; case p' of  -- may be wrapped ConPatIn
                                 (L _ (ParPat {})) -> return $ unLoc p'
-                                _                 -> return $ ParPat p' }
-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
-cvtp TH.WildP          = return $ WildPat placeHolderType
+                                _                 -> return $ ParPat noExt p' }
+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
+                            ; return $ AsPat noExt s' p' }
+cvtp TH.WildP          = return $ WildPat noExt
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
                             ; return $ ConPatIn c'
                                      $ Hs.RecCon (HsRecFields fs' Nothing) }
 cvtp (ListP ps)        = do { ps' <- cvtPats ps
-                            ; return $ ListPat ps' placeHolderType Nothing }
+                            ; return
+                                   $ ListPat noExt ps'}
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPatIn p' (mkLHsSigWcType t') }
+                            ; return $ SigPat (mkLHsSigWcType t') p' }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
-                            ; return $ ViewPat e' p' placeHolderType }
+                            ; return $ ViewPat noExt e' p'}
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
 cvtPatFld (s,p)
@@ -1126,12 +1213,6 @@ cvtPatFld (s,p)
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
-wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat p
-wrap_conpat p                                   = return p
-
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
 
@@ -1155,11 +1236,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
 cvt_tv (TH.PlainTV nm)
   = do { nm' <- tNameL nm
-       ; returnL $ UserTyVar nm' }
+       ; returnL $ UserTyVar noExt nm' }
 cvt_tv (TH.KindedTV nm ki)
   = do { nm' <- tNameL nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' ki' }
+       ; returnL $ KindedTyVar noExt nm' ki' }
 
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
@@ -1176,14 +1257,17 @@ cvtPred = cvtType
 cvtDerivClause :: TH.DerivClause
                -> CvtM (LHsDerivingClause GhcPs)
 cvtDerivClause (TH.DerivClause ds ctxt)
-  = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
-       ; let ds' = fmap (L loc . cvtDerivStrategy) ds
-       ; returnL $ HsDerivingClause ds' ctxt' }
-
-cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
-cvtDerivStrategy TH.StockStrategy    = Hs.StockStrategy
-cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy
-cvtDerivStrategy TH.NewtypeStrategy  = Hs.NewtypeStrategy
+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
+       ; ds'   <- traverse cvtDerivStrategy ds
+       ; returnL $ HsDerivingClause noExt ds' ctxt' }
+
+cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy
+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy
+cvtDerivStrategy (TH.ViaStrategy ty) = do
+  ty' <- cvtType ty
+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')
 
 cvtType :: TH.Type -> CvtM (LHsType GhcPs)
 cvtType = cvtTypeKind "type"
@@ -1196,17 +1280,18 @@ cvtTypeKind ty_str ty
              | tys' `lengthIs` n         -- Saturated
              -> if n==1 then return (head tys') -- Singleton tuples treated
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
+                        else returnL (HsTupleTy noExt
+                                                  HsBoxedOrConstraintTuple tys')
              | n == 1
              -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                                (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
              | tys' `lengthIs` n         -- Saturated
-             -> returnL (HsTupleTy HsUnboxedTuple tys')
+             -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                              (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
            UnboxedSumT n
              | n < 2
@@ -1215,28 +1300,42 @@ cvtTypeKind ty_str ty
                         , nest 2 $
                             text "Sums must have an arity of at least 2" ]
              | tys' `lengthIs` n -- Saturated
-             -> returnL (HsSumTy tys')
+             -> returnL (HsSumTy noExt tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+             -> mk_apps (HsTyVar noExt NotPromoted
+                                              (noLoc (getRdrName (sumTyCon n))))
                         tys'
            ArrowT
              | [x',y'] <- tys' -> do
-                 case x' of
-                   (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
-                                         ; returnL (HsFunTy x'' y') }
-                   _  -> returnL (HsFunTy x' y')
+                 x'' <- case x' of
+                          L _ HsFunTy{}    -> returnL (HsParTy noExt x')
+                          L _ HsForAllTy{} -> returnL (HsParTy noExt x')
+                                                               -- #14646
+                          L _ HsQualTy{}   -> returnL (HsParTy noExt x')
+                                                               -- #15324
+                          _                -> return x'
+                 returnL (HsFunTy noExt x'' y')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+                  mk_apps (HsTyVar noExt NotPromoted
+                           (noLoc (getRdrName funTyCon)))
                           tys'
            ListT
-             | [x']    <- tys' -> returnL (HsListTy x')
+             | [x']    <- tys' -> returnL (HsListTy noExt x')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+                  mk_apps (HsTyVar noExt NotPromoted
+                           (noLoc (getRdrName listTyCon)))
                            tys'
            VarT nm -> do { nm' <- tNameL nm
-                         ; mk_apps (HsTyVar NotPromoted nm') tys' }
+                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                         ; -- ConT can contain both data constructor (i.e.,
+                           -- promoted) names and other (i.e, unpromoted)
+                           -- names, as opposed to PromotedT, which can only
+                           -- contain data constructor names. See #15572.
+                           let prom = if isRdrDataCon nm'
+                                      then Promoted
+                                      else NotPromoted
+                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
 
            ForallT tvs cxt ty
              | null tys'
@@ -1252,11 +1351,11 @@ cvtTypeKind ty_str ty
            SigT ty ki
              -> do { ty' <- cvtType ty
                    ; ki' <- cvtKind ki
-                   ; mk_apps (HsKindSig ty' ki') tys'
+                   ; mk_apps (HsKindSig noExt ty' ki') tys'
                    }
 
            LitT lit
-             -> returnL (HsTyLit (cvtTyLit lit))
+             -> returnL (HsTyLit noExt (cvtTyLit lit))
 
            WildCardT
              -> mk_apps mkAnonWildCardTy tys'
@@ -1265,59 +1364,66 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+                   ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
                    }
 
            UInfixT t1 s t2
-             -> do { t1' <- cvtType t1
-                   ; t2' <- cvtType t2
-                   ; s'  <- tconName s
-                   ; return $ cvtOpAppT t1' s' t2'
+             -> do { t2' <- cvtType t2
+                   ; cvtOpAppT t1 s t2'
                    } -- Note [Converting UInfix]
 
            ParensT t
              -> do { t' <- cvtType t
-                   ; returnL $ HsParTy t'
+                   ; returnL $ HsParTy noExt t'
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                              ; mk_apps (HsTyVar noExt Promoted
+                                                             (noLoc nm')) tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
              | n == 1
              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
              | m == n   -- Saturated
-             -> do  { let kis = replicate m placeHolderKind
-                    ; returnL (HsExplicitTupleTy kis tys')
-                    }
+             -> returnL (HsExplicitTupleTy noExt tys')
+             | otherwise
+             -> mk_apps (HsTyVar noExt Promoted
+                               (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
              where
                m = length tys'
 
            PromotedNilT
-             -> returnL (HsExplicitListTy Promoted placeHolderKind [])
+             -> returnL (HsExplicitListTy noExt Promoted [])
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
-             | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
-             -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
+             | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+             -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+             -> mk_apps (HsTyVar noExt Promoted
+                         (noLoc (getRdrName consDataCon)))
                         tys'
 
            StarT
-             -> returnL (HsTyVar NotPromoted (noLoc
+             -> returnL (HsTyVar noExt NotPromoted (noLoc
                                               (getRdrName liftedTypeKindTyCon)))
 
            ConstraintT
-             -> returnL (HsTyVar NotPromoted
+             -> returnL (HsTyVar noExt NotPromoted
                               (noLoc (getRdrName constraintKindTyCon)))
 
            EqualityT
-             | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+             | [x',y'] <- tys' ->
+                   returnL (HsOpTy noExt x' (noLoc eqTyCon_RDR) y')
              | otherwise ->
-                   mk_apps (HsTyVar NotPromoted
-                            (noLoc (getRdrName eqPrimTyCon))) tys'
+                   mk_apps (HsTyVar noExt NotPromoted
+                            (noLoc eqTyCon_RDR)) tys'
+           ImplicitParamT n t
+             -> do { n' <- wrapL $ ipName n
+                   ; t' <- cvtType t
+                   ; returnL (HsIParamTy noExt n' t')
+                   }
 
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
@@ -1328,22 +1434,46 @@ mk_apps head_ty []       = returnL head_ty
 mk_apps head_ty (ty:tys) =
   do { head_ty' <- returnL head_ty
      ; p_ty      <- add_parens ty
-     ; mk_apps (HsAppTy head_ty' p_ty) tys }
+     ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
   where
-    add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)
-    add_parens t@(L _ HsFunTy{}) = returnL (HsParTy t)
-    add_parens t                 = return t
+    -- See Note [Adding parens for splices]
+    add_parens lt@(L _ t)
+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
+      | otherwise                   = return lt
 
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
 wrap_apps t                  = return t
 
+-- ---------------------------------------------------------------------
+-- Note [Adding parens for splices]
+{-
+The hsSyn representation of parsed source explicitly contains all the original
+parens, as written in the source.
+
+When a Template Haskell (TH) splice is evaluated, the original splice is first
+renamed and type checked and then finally converted to core in DsMeta. This core
+is then run in the TH engine, and the result comes back as a TH AST.
+
+In the process, all parens are stripped out, as they are not needed.
+
+This Convert module then converts the TH AST back to hsSyn AST.
+
+In order to pretty-print this hsSyn AST, parens need to be adde back at certain
+points so that the code is readable with its original meaning.
+
+So scattered through Convert.hs are various points where parens are added.
+
+See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
+-}
+-- ---------------------------------------------------------------------
+
 -- | Constructs an arrow type with a specified return type
 mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
     where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
           go arg ret_ty = do { ret_ty_l <- returnL ret_ty
-                             ; return (HsFunTy arg ret_ty_l) }
+                             ; return (HsFunTy noExt arg ret_ty_l) }
 
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
 split_ty_app ty = go ty []
@@ -1355,23 +1485,20 @@ cvtTyLit :: TH.TyLit -> HsTyLit
 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 
-{- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
-   structure in them.
--}
-cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
-cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
-  = L (combineSrcSpans loc1 loc2) $
-    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
-  where
-    t1' | L _ (HsAppsTy t1s) <- t1
-        = t1s
-        | otherwise
-        = [noLoc $ HsAppPrefix t1]
+{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
+application @x `op` y@. The produced tree of infix types will be right-biased,
+provided @y@ is.
 
-    t2' | L _ (HsAppsTy t2s) <- t2
-        = t2s
-        | otherwise
-        = [noLoc $ HsAppPrefix t2]
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT (UInfixT x op2 y) op1 z
+  = do { l <- cvtOpAppT y op1 z
+       ; cvtOpAppT x op2 l }
+cvtOpAppT x op y
+  = do { op' <- tconNameL op
+       ; x' <- cvtType x
+       ; returnL (mkHsOpTy x' op' y) }
 
 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
 cvtKind = cvtTypeKind "kind"
@@ -1381,18 +1508,18 @@ cvtKind = cvtTypeKind "kind"
 -- signature is possible).
 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
                               -> CvtM (LFamilyResultSig GhcPs)
-cvtMaybeKindToFamilyResultSig Nothing   = returnL Hs.NoSig
+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExt)
 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
-                                             ; returnL (Hs.KindSig ki') }
+                                             ; returnL (Hs.KindSig noExt ki') }
 
 -- | Convert type family result signature. Used with both open and closed type
 -- families.
 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
-cvtFamilyResultSig TH.NoSig           = returnL Hs.NoSig
+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExt)
 cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki
-                                           ; returnL (Hs.KindSig ki') }
+                                           ; returnL (Hs.KindSig noExt  ki') }
 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
-                                           ; returnL (Hs.TyVarSig tv) }
+                                           ; returnL (Hs.TyVarSig noExt tv) }
 
 -- | Convert injectivity annotation of a type family.
 cvtInjectivityAnnotation :: TH.InjectivityAnn
@@ -1411,13 +1538,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
   | null univs, null reqs = do { l   <- getL
                                ; ty' <- cvtType (ForallT exis provs ty)
                                ; return $ L l (HsQualTy { hst_ctxt = L l []
+                                                        , hst_xqual = noExt
                                                         , hst_body = ty' }) }
   | null reqs             = do { l      <- getL
                                ; univs' <- hsQTvExplicit <$> cvtTvs univs
                                ; ty'    <- cvtType (ForallT exis provs ty)
                                ; let forTy = HsForAllTy { hst_bndrs = univs'
+                                                        , hst_xforall = noExt
                                                         , hst_body = L l cxtTy }
                                      cxtTy = HsQualTy { hst_ctxt = L l []
+                                                      , hst_xqual = noExt
                                                       , hst_body = ty' }
                                ; return $ L l forTy }
   | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
@@ -1467,15 +1597,16 @@ mkHsForAllTy :: [TH.TyVarBndr]
              -> SrcSpan
              -- ^ The location of the returned 'LHsType' if it needs an
              --   explicit forall
-             -> LHsQTyVars name
+             -> LHsQTyVars GhcPs
              -- ^ The converted type variable binders
-             -> LHsType name
+             -> LHsType GhcPs
              -- ^ The converted rho type
-             -> LHsType name
+             -> LHsType GhcPs
              -- ^ The complete type, quantified with a forall if necessary
 mkHsForAllTy tvs loc tvs' rho_ty
   | null tvs  = rho_ty
   | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+                                   , hst_xforall = noExt
                                    , hst_body = rho_ty }
 
 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
@@ -1490,15 +1621,16 @@ mkHsQualTy :: TH.Cxt
            -> SrcSpan
            -- ^ The location of the returned 'LHsType' if it needs an
            --   explicit context
-           -> LHsContext name
+           -> LHsContext GhcPs
            -- ^ The converted context
-           -> LHsType name
+           -> LHsType GhcPs
            -- ^ The converted tau type
-           -> LHsType name
+           -> LHsType GhcPs
            -- ^ The complete type, qualified with a context if necessary
 mkHsQualTy ctxt loc ctxt' ty
   | null ctxt = ty
-  | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+  | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+                                 , hst_body = ty }
 
 --------------------------------------------------------------------
 --      Turning Name back into RdrName
@@ -1528,6 +1660,11 @@ tName n = cvtName OccName.tvName n
 tconNameL n = wrapL (tconName n)
 tconName n = cvtName OccName.tcClsName n
 
+ipName :: String -> CvtM HsIPName
+ipName n
+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
+       ; return (HsIPName (fsLit n)) }
+
 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 cvtName ctxt_ns (TH.Name occ flavour)
   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
@@ -1588,8 +1725,14 @@ thRdrName loc ctxt_ns th_occ th_name
     occ :: OccName.OccName
     occ = mk_occ ctxt_ns th_occ
 
+-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
+-- See Trac #13776.
 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
-thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
+thOrigRdrName occ th_ns pkg mod =
+  let occ' = mk_occ (mk_ghc_ns th_ns) occ
+  in case isBuiltInOcc_maybe occ' of
+       Just name -> nameRdrName name
+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
 
 thRdrNameGuesses :: TH.Name -> [RdrName]
 thRdrNameGuesses (TH.Name occ flavour)
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index f08a6af700..98f503b0d9 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -14,9 +14,12 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsBinds where
 
+import GhcPrelude
+
 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                MatchGroup, pprFunBind,
                                GRHSs, pprPatBind )
@@ -54,7 +57,7 @@ Global bindings (where clauses)
 -}
 
 -- During renaming, we need bindings where the left-hand sides
--- have been renamed but the the right-hand sides have not.
+-- have been renamed but the right-hand sides have not.
 -- the ...LR datatypes are parametrized by two id types,
 -- one for the left and one for the right.
 -- Other than during renaming, these will be the same.
@@ -70,23 +73,34 @@ type LHsLocalBinds id = Located (HsLocalBinds id)
 -- Bindings in a 'let' expression
 -- or a 'where' clause
 data HsLocalBindsLR idL idR
-  = HsValBinds (HsValBindsLR idL idR)
+  = HsValBinds
+        (XHsValBinds idL idR)
+        (HsValBindsLR idL idR)
       -- ^ Haskell Value Bindings
 
          -- There should be no pattern synonyms in the HsValBindsLR
          -- These are *local* (not top level) bindings
-         -- The parser accepts them, however, leaving the the
+         -- The parser accepts them, however, leaving the
          -- renamer to report them
 
-  | HsIPBinds  (HsIPBinds idR)
+  | HsIPBinds
+        (XHsIPBinds idL idR)
+        (HsIPBinds idR)
       -- ^ Haskell Implicit Parameter Bindings
 
-  | EmptyLocalBinds
+  | EmptyLocalBinds (XEmptyLocalBinds idL idR)
       -- ^ Empty Local Bindings
 
+  | XHsLocalBindsLR
+        (XXHsLocalBindsLR idL idR)
+
+type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = NoExt
+type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = NoExt
+type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt
+
 type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
 
-deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
 
 -- | Haskell Value Bindings
 type HsValBinds id = HsValBindsLR id id
@@ -101,18 +115,31 @@ data HsValBindsLR idL idR
     -- Before renaming RHS; idR is always RdrName
     -- Not dependency analysed
     -- Recursive by default
-    ValBindsIn
+    ValBinds
+        (XValBinds idL idR)
         (LHsBindsLR idL idR) [LSig idR]
 
     -- | Value Bindings Out
     --
     -- After renaming RHS; idR can be Name or Id Dependency analysed,
     -- later bindings in the list may depend on earlier ones.
-  | ValBindsOut
-        [(RecFlag, LHsBinds idL)]
-        [LSig GhcRn] -- AZ: how to do this?
+  | XValBindsLR
+      (XXValBindsLR idL idR)
+
+-- ---------------------------------------------------------------------
+-- Deal with ValBindsOut
+
+-- TODO: make this the only type for ValBinds
+data NHsValBindsLR idL
+  = NValBinds
+      [(RecFlag, LHsBinds idL)]
+      [LSig GhcRn]
 
-deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR)
+type instance XValBinds    (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
+            = NHsValBindsLR (GhcPass pL)
+
+-- ---------------------------------------------------------------------
 
 -- | Located Haskell Binding
 type LHsBind  id = LHsBindLR  id id
@@ -129,9 +156,8 @@ type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
 -- | Located Haskell Binding with separate Left and Right identifier types
 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 
-{- Note [Varieties of binding pattern matches]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [FunBind vs PatBind]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~
 The distinction between FunBind and PatBind is a bit subtle. FunBind covers
 patterns which resemble function bindings and simple variable bindings.
 
@@ -142,12 +168,17 @@ patterns which resemble function bindings and simple variable bindings.
     x `f` y = e     -- FunRhs has Infix
 
 The actual patterns and RHSs of a FunBind are encoding in fun_matches.
-The m_ctxt field of Match will be FunRhs and carries two bits of information
-about the match,
+The m_ctxt field of each Match in fun_matches will be FunRhs and carries
+two bits of information about the match,
 
-  * the mc_strictness field describes whether the match is decorated with a bang
-    (e.g. `!x = e`)
-  * the mc_fixity field describes the fixity of the function binder
+  * The mc_fixity field on each Match describes the fixity of the
+    function binder in that match.  E.g. this is legal:
+         f True False  = e1
+         True `f` True = e2
+
+  * The mc_strictness field is used /only/ for nullary FunBinds: ones
+    with one Match, which has no pats. For these, it describes whether
+    the match is decorated with a bang (e.g. `!x = e`).
 
 By contrast, PatBind represents data constructor patterns, as well as a few
 other interesting cases. Namely,
@@ -175,7 +206,7 @@ data HsBindLR idL idR
     --                                        @(f :: a -> a) = ... @
     --
     -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
-    -- 'MatchContext'. See Note [Varieties of binding pattern matches] for
+    -- 'MatchContext'. See Note [FunBind vs PatBind] for
     -- details about the relationship between FunBind and PatBind.
     --
     --  'ApiAnnotation.AnnKeywordId's
@@ -188,6 +219,11 @@ data HsBindLR idL idR
     -- For details on above see note [Api annotations] in ApiAnnotation
     FunBind {
 
+        fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
+                                --  the locally-bound
+                                -- free variables of this defn.
+                                -- See Note [Bind free vars]
+
         fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
 
         fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
@@ -206,12 +242,6 @@ data HsBindLR idL idR
                                 -- type         Int -> forall a'. a' -> a'
                                 -- Notice that the coercion captures the free a'.
 
-        bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
-                                --  the locally-bound
-                                -- free variables of this defn.
-                                -- See Note [Bind free vars]
-
-
         fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
     }
 
@@ -219,7 +249,7 @@ data HsBindLR idL idR
   --
   -- The pattern is never a simple variable;
   -- That case is done by FunBind.
-  -- See Note [Varieties of binding pattern matches] for details about the
+  -- See Note [FunBind vs PatBind] for details about the
   -- relationship between FunBind and PatBind.
 
   --
@@ -229,10 +259,9 @@ data HsBindLR idL idR
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | PatBind {
+        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]
         pat_lhs    :: LPat idL,
         pat_rhs    :: GRHSs idR (LHsExpr idR),
-        pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs
-        bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
         pat_ticks  :: ([Tickish Id], [[Tickish Id]])
                -- ^ Ticks to put on the rhs, if any, and ticks to put on
                -- the bound variables.
@@ -243,6 +272,7 @@ data HsBindLR idL idR
   -- Dictionary binding and suchlike.
   -- All VarBinds are introduced by the type checker
   | VarBind {
+        var_ext    :: XVarBind idL idR,
         var_id     :: IdP idL,
         var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency
         var_inline :: Bool           -- ^ True <=> inline this binding regardless
@@ -251,6 +281,7 @@ data HsBindLR idL idR
 
   -- | Abstraction Bindings
   | AbsBinds {                      -- Binds abstraction; TRANSLATION
+        abs_ext     :: XAbsBinds idL idR,
         abs_tvs     :: [TyVar],
         abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints
 
@@ -265,26 +296,15 @@ data HsBindLR idL idR
         abs_ev_binds :: [TcEvBinds],
 
         -- | Typechecked user bindings
-        abs_binds    :: LHsBinds idL
-    }
+        abs_binds    :: LHsBinds idL,
 
-  -- | Abstraction Bindings Signature
-  | AbsBindsSig {  -- Simpler form of AbsBinds, used with a type sig
-                   -- in tcPolyCheck. Produces simpler desugaring and
-                   -- is necessary to avoid #11405, comment:3.
-        abs_tvs     :: [TyVar],
-        abs_ev_vars :: [EvVar],
-
-        abs_sig_export :: IdP idL,  -- like abe_poly
-        abs_sig_prags  :: TcSpecPrags,
-
-        abs_sig_ev_bind :: TcEvBinds,  -- no list needed here
-        abs_sig_bind    :: LHsBind idL -- always only one, and it's always a
-                                       -- FunBind
+        abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]
     }
 
   -- | Patterns Synonym Binding
-  | PatSynBind (PatSynBind idL idR)
+  | PatSynBind
+        (XPatSynBind idL idR)
+        (PatSynBind idL idR)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
         --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
         --          'ApiAnnotation.AnnWhere'
@@ -292,7 +312,26 @@ data HsBindLR idL idR
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
+  | XHsBindsLR (XXHsBindsLR idL idR)
+
+data NPatBindTc = NPatBindTc {
+     pat_fvs :: NameSet, -- ^ Free variables
+     pat_rhs_ty :: Type  -- ^ Type of the GRHSs
+     } deriving Data
+
+type instance XFunBind    (GhcPass pL) GhcPs = NoExt
+type instance XFunBind    (GhcPass pL) GhcRn = NameSet -- Free variables
+type instance XFunBind    (GhcPass pL) GhcTc = NameSet -- Free variables
+
+type instance XPatBind    GhcPs (GhcPass pR) = NoExt
+type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- Free variables
+type instance XPatBind    GhcTc (GhcPass pR) = NPatBindTc
+
+type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExt
+type instance XAbsBinds   (GhcPass pL) (GhcPass pR) = NoExt
+type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt
+
 
         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
         --
@@ -308,13 +347,18 @@ deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
 
 -- | Abtraction Bindings Export
 data ABExport p
-  = ABE { abe_poly      :: IdP p -- ^ Any INLINE pragmas is attached to this Id
+  = ABE { abe_ext       :: XABE p
+        , abe_poly      :: IdP p -- ^ Any INLINE pragma is attached to this Id
         , abe_mono      :: IdP p
         , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]
              -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
         , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas
-  }
-deriving instance (DataId p) => Data (ABExport p)
+        }
+   | XABExport (XXABExport p)
+
+type instance XABE       (GhcPass p) = NoExt
+type instance XXABExport (GhcPass p) = NoExt
+
 
 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
 --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
@@ -325,14 +369,21 @@ deriving instance (DataId p) => Data (ABExport p)
 
 -- | Pattern Synonym binding
 data PatSynBind idL idR
-  = PSB { psb_id   :: Located (IdP idL),       -- ^ Name of the pattern synonym
-          psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
+  = PSB { psb_ext  :: XPSB idL idR,            -- ^ Post renaming, FVs.
+                                               -- See Note [Bind free vars]
+          psb_id   :: Located (IdP idL),       -- ^ Name of the pattern synonym
           psb_args :: HsPatSynDetails (Located (IdP idR)),
                                                -- ^ Formal parameter names
           psb_def  :: LPat idR,                -- ^ Right-hand side
           psb_dir  :: HsPatSynDir idR          -- ^ Directionality
-  }
-deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
+     }
+   | XPatSynBind (XXPatSynBind idL idR)
+
+type instance XPSB         (GhcPass idL) GhcPs = NoExt
+type instance XPSB         (GhcPass idL) GhcRn = NameSet
+type instance XPSB         (GhcPass idL) GhcTc = NameSet
+
+type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt
 
 {-
 Note [AbsBinds]
@@ -477,6 +528,53 @@ bindings only when
    lacks a user type signature
  * The group forms a strongly connected component
 
+
+Note [The abs_sig field of AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The abs_sig field supports a couple of special cases for bindings.
+Consider
+
+  x :: Num a => (# a, a #)
+  x = (# 3, 4 #)
+
+The general desugaring for AbsBinds would give
+
+  x = /\a. \ ($dNum :: Num a) ->
+      letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
+      xm
+
+But that has an illegal let-binding for an unboxed tuple.  In this
+case we'd prefer to generate the (more direct)
+
+  x = /\ a. \ ($dNum :: Num a) ->
+     (# fromInteger $dNum 3, fromInteger $dNum 4 #)
+
+A similar thing happens with representation-polymorphic defns
+(Trac #11405):
+
+  undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
+  undef = error "undef"
+
+Again, the vanilla desugaring gives a local let-binding for a
+representation-polymorphic (undefm :: a), which is illegal.  But
+again we can desugar without a let:
+
+  undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
+
+The abs_sig field supports this direct desugaring, with no local
+let-bining.  When abs_sig = True
+
+ * the abs_binds is single FunBind
+
+ * the abs_exports is a singleton
+
+ * we have a complete type sig for binder
+   and hence the abs_binds is non-recursive
+   (it binds the mono_id but refers to the poly_id
+
+These properties are exploited in DsBinds.dsAbsBinds to
+generate code without a let-binding.
+
 Note [ABExport wrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -520,20 +618,21 @@ Specifically,
     it's just an error thunk
 -}
 
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
         => Outputable (HsLocalBindsLR idL idR) where
-  ppr (HsValBinds bs) = ppr bs
-  ppr (HsIPBinds bs)  = ppr bs
-  ppr EmptyLocalBinds = empty
+  ppr (HsValBinds _ bs)   = ppr bs
+  ppr (HsIPBinds _ bs)    = ppr bs
+  ppr (EmptyLocalBinds _) = empty
+  ppr (XHsLocalBindsLR x) = ppr x
 
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
         => Outputable (HsValBindsLR idL idR) where
-  ppr (ValBindsIn binds sigs)
+  ppr (ValBinds _ binds sigs)
    = pprDeclList (pprLHsBindsForUser binds sigs)
 
-  ppr (ValBindsOut sccs sigs)
+  ppr (XValBindsLR (NValBinds sccs sigs))
     = getPprStyle $ \ sty ->
       if debugStyle sty then    -- Print with sccs showing
         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
@@ -544,17 +643,16 @@ instance (SourceTextX idL, SourceTextX idR,
      pp_rec Recursive    = text "rec"
      pp_rec NonRecursive = text "nonrec"
 
-pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
-                OutputableBndrId idL, OutputableBndrId idR)
-            => LHsBindsLR idL idR -> SDoc
+pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+            => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
 pprLHsBinds binds
   | isEmptyLHsBinds binds = empty
   | otherwise = pprDeclList (map ppr (bagToList binds))
 
-pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
-                       OutputableBndrId idL, OutputableBndrId idR,
-                       SourceTextX id2, OutputableBndrId id2)
-                   => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
+pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
+                       OutputableBndrId (GhcPass idR),
+                       OutputableBndrId (GhcPass id2))
+     => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
 --  pprLHsBindsForUser is different to pprLHsBinds because
 --  a) No braces: 'let' and 'where' include a list of HsBindGroups
 --     and we don't want several groups of bindings each
@@ -583,25 +681,33 @@ pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
 pprDeclList ds = pprDeeperList vcat ds
 
 ------------
-emptyLocalBinds :: HsLocalBindsLR a b
-emptyLocalBinds = EmptyLocalBinds
-
-isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
-isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
-isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
-isEmptyLocalBinds EmptyLocalBinds = True
+emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
+emptyLocalBinds = EmptyLocalBinds noExt
+
+-- AZ:These functions do not seem to be used at all?
+isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
+isEmptyLocalBindsTc (HsValBinds _ ds)   = isEmptyValBinds ds
+isEmptyLocalBindsTc (HsIPBinds _ ds)    = isEmptyIPBindsTc ds
+isEmptyLocalBindsTc (EmptyLocalBinds _) = True
+isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
+
+isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyLocalBindsPR (HsValBinds _ ds)   = isEmptyValBinds ds
+isEmptyLocalBindsPR (HsIPBinds _ ds)    = isEmptyIPBindsPR ds
+isEmptyLocalBindsPR (EmptyLocalBinds _) = True
+isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
 
 eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
-eqEmptyLocalBinds EmptyLocalBinds = True
-eqEmptyLocalBinds _               = False
+eqEmptyLocalBinds (EmptyLocalBinds _) = True
+eqEmptyLocalBinds _                   = False
 
-isEmptyValBinds :: HsValBindsLR a b -> Bool
-isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
+isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyValBinds (ValBinds _ ds sigs)  = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
 
-emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
-emptyValBindsIn  = ValBindsIn emptyBag []
-emptyValBindsOut = ValBindsOut []      []
+emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
+emptyValBindsIn  = ValBinds noExt emptyBag []
+emptyValBindsOut = XValBindsLR (NValBinds [] [])
 
 emptyLHsBinds :: LHsBindsLR idL idR
 emptyLHsBinds = emptyBag
@@ -610,22 +716,23 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 isEmptyLHsBinds = isEmptyBag
 
 ------------
-plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
-plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
-  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
-plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
-  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+               -> HsValBinds(GhcPass a)
+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
+  = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
+               (XValBindsLR (NValBinds ds2 sigs2))
+  = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
 plusHsValBinds _ _
   = panic "HsBinds.plusHsValBinds"
 
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
          => Outputable (HsBindLR idL idR) where
     ppr mbind = ppr_monobind mbind
 
-ppr_monobind :: (SourceTextX idL, SourceTextX idR,
-                 OutputableBndrId idL, OutputableBndrId idR)
-             => HsBindLR idL idR -> SDoc
+ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+             => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
 
 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
   = pprPatBind pat grhss
@@ -637,10 +744,10 @@ ppr_monobind (FunBind { fun_id = fun,
                         fun_tick = ticks })
   = pprTicks empty (if null ticks then empty
                     else text "-- ticks = " <> ppr ticks)
-    $$  ifPprDebug (pprBndr LetBind (unLoc fun))
+    $$  whenPprDebug (pprBndr LetBind (unLoc fun))
     $$  pprFunBind  matches
-    $$  ifPprDebug (ppr wrap)
-ppr_monobind (PatSynBind psb) = ppr psb
+    $$  whenPprDebug (ppr wrap)
+ppr_monobind (PatSynBind _ psb) = ppr psb
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
                        , abs_ev_binds = ev_binds })
@@ -658,30 +765,17 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
       , text "Evidence:" <+> ppr ev_binds ]
     else
       pprLHsBinds val_binds
-ppr_monobind (AbsBindsSig { abs_tvs         = tyvars
-                          , abs_ev_vars     = dictvars
-                          , abs_sig_export  = poly_id
-                          , abs_sig_ev_bind = ev_bind
-                          , abs_sig_bind    = bind })
-  = sdocWithDynFlags $ \ dflags ->
-    if gopt Opt_PrintTypecheckerElaboration dflags then
-      hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
-                               <+> brackets (interpp'SP dictvars))
-         2 $ braces $ vcat
-      [ text "Exported type:" <+> pprBndr LetBind poly_id
-      , text "Bind:"     <+> ppr bind
-      , text "Evidence:" <+> ppr ev_bind ]
-    else
-      ppr bind
+ppr_monobind (XHsBindsLR x) = ppr x
 
-instance (OutputableBndrId p) => Outputable (ABExport p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where
   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
     = vcat [ ppr gbl <+> text "<=" <+> ppr lcl
            , nest 2 (pprTcSpecPrags prags)
            , nest 2 (text "wrap:" <+> ppr wrap)]
+  ppr (XABExport x) = ppr x
 
-instance (SourceTextX idR,
-          OutputableBndrId idL, OutputableBndrId idR)
+instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
+         Outputable (XXPatSynBind idL idR))
           => Outputable (PatSynBind idL idR) where
   ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
             psb_dir = dir })
@@ -691,17 +785,17 @@ instance (SourceTextX idR,
       ppr_simple syntax = syntax <+> ppr pat
 
       ppr_details = case details of
-          InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
-          PrefixPatSyn vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
-          RecordPatSyn vs   ->
-            pprPrefixOcc psyn
-                      <> braces (sep (punctuate comma (map ppr vs)))
+          InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
+          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
+          RecCon vs      -> pprPrefixOcc psyn
+                            <> braces (sep (punctuate comma (map ppr vs)))
 
       ppr_rhs = case dir of
           Unidirectional           -> ppr_simple (text "<-")
           ImplicitBidirectional    -> ppr_simple equals
           ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
                                       (nest 2 $ pprFunBind mg)
+  ppr (XPatSynBind x) = ppr x
 
 pprTicks :: SDoc -> SDoc -> SDoc
 -- Print stuff about ticks only when -dppr-debug is on, to avoid
@@ -724,13 +818,27 @@ pprTicks pp_no_debug pp_when_debug
 -- | Haskell Implicit Parameter Bindings
 data HsIPBinds id
   = IPBinds
+        (XIPBinds id)
         [LIPBind id]
-        TcEvBinds       -- Only in typechecker output; binds
-                        -- uses of the implicit parameters
-deriving instance (DataId id) => Data (HsIPBinds id)
+        -- TcEvBinds       -- Only in typechecker output; binds
+        --                 -- uses of the implicit parameters
+  | XHsIPBinds (XXHsIPBinds id)
+
+type instance XIPBinds       GhcPs = NoExt
+type instance XIPBinds       GhcRn = NoExt
+type instance XIPBinds       GhcTc = TcEvBinds -- binds uses of the
+                                               -- implicit parameters
 
-isEmptyIPBinds :: HsIPBinds id -> Bool
-isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
+
+type instance XXHsIPBinds    (GhcPass p) = NoExt
+
+isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
+isEmptyIPBindsPR (IPBinds _ is) = null is
+isEmptyIPBindsPR (XHsIPBinds _) = True
+
+isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
+isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
+isEmptyIPBindsTc (XHsIPBinds _) = True
 
 -- | Located Implicit Parameter Binding
 type LIPBind id = Located (IPBind id)
@@ -750,18 +858,27 @@ type LIPBind id = Located (IPBind id)
 
 -- For details on above see note [Api annotations] in ApiAnnotation
 data IPBind id
-  = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
-deriving instance (DataId name) => Data (IPBind name)
-
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
-  ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
-                        $$ ifPprDebug (ppr ds)
-
-instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
-  ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
+  = IPBind
+        (XCIPBind id)
+        (Either (Located HsIPName) (IdP id))
+        (LHsExpr id)
+  | XIPBind (XXIPBind id)
+
+type instance XCIPBind    (GhcPass p) = NoExt
+type instance XXIPBind    (GhcPass p) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (HsIPBinds p) where
+  ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
+                        $$ whenPprDebug (ppr ds)
+  ppr (XHsIPBinds x) = ppr x
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
+  ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
     where name = case lr of
                    Left (L _ ip) -> pprBndr LetBind ip
                    Right     id  -> pprBndr LetBind id
+  ppr (XIPBind x) = ppr x
 
 {-
 ************************************************************************
@@ -798,6 +915,7 @@ data Sig pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
     TypeSig
+       (XTypeSig pass)
        [Located (IdP pass)]  -- LHS of the signature; e.g.  f,g,h :: blah
        (LHsSigWcType pass)   -- RHS of the signature; can have wildcards
 
@@ -810,7 +928,7 @@ data Sig pass
       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-  | PatSynSig [Located (IdP pass)] (LHsSigType pass)
+  | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)
       -- P :: forall a b. Req => Prov => ty
 
       -- | A signature for a class method
@@ -823,14 +941,14 @@ data Sig pass
       --
       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
       --           'ApiAnnotation.AnnDcolon'
-  | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass)
+  | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)
 
         -- | A type signature in generated code, notably the code
         -- generated for record selectors.  We simply record
         -- the desired Id itself, replete with its name, type
         -- and IdDetails.  Otherwise it's just like a type
         -- signature: there should be an accompanying binding
-  | IdSig Id
+  | IdSig (XIdSig pass) Id
 
         -- | An ordinary fixity declaration
         --
@@ -841,7 +959,7 @@ data Sig pass
         --           'ApiAnnotation.AnnVal'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | FixSig (FixitySig pass)
+  | FixSig (XFixSig pass) (FixitySig pass)
 
         -- | An inline pragma
         --
@@ -854,7 +972,8 @@ data Sig pass
         --       'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | InlineSig   (Located (IdP pass)) -- Function name
+  | InlineSig   (XInlineSig pass)
+                (Located (IdP pass)) -- Function name
                 InlinePragma         -- Never defaultInlinePragma
 
         -- | A specialisation pragma
@@ -869,7 +988,8 @@ data Sig pass
         --      'ApiAnnotation.AnnDcolon'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | SpecSig     (Located (IdP pass)) -- Specialise a function or datatype  ...
+  | SpecSig     (XSpecSig pass)
+                (Located (IdP pass)) -- Specialise a function or datatype  ...
                 [LHsSigType pass]  -- ... to these types
                 InlinePragma       -- The pragma on SPECIALISE_INLINE form.
                                    -- If it's just defaultInlinePragma, then we said
@@ -886,7 +1006,7 @@ data Sig pass
         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | SpecInstSig SourceText (LHsSigType pass)
+  | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)
                   -- Note [Pragma source text] in BasicTypes
 
         -- | A minimal complete definition pragma
@@ -898,7 +1018,8 @@ data Sig pass
         --      'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | MinimalSig SourceText (LBooleanFormula (Located (IdP pass)))
+  | MinimalSig (XMinimalSig pass)
+               SourceText (LBooleanFormula (Located (IdP pass)))
                -- Note [Pragma source text] in BasicTypes
 
         -- | A "set cost centre" pragma for declarations
@@ -909,7 +1030,8 @@ data Sig pass
         --
         -- > {-# SCC funName "cost_centre_name" #-}
 
-  | SCCFunSig  SourceText      -- Note [Pragma source text] in BasicTypes
+  | SCCFunSig  (XSCCFunSig pass)
+               SourceText      -- Note [Pragma source text] in BasicTypes
                (Located (IdP pass))  -- Function name
                (Maybe (Located StringLiteral))
        -- | A complete match pragma
@@ -919,18 +1041,34 @@ data Sig pass
        -- Used to inform the pattern match checker about additional
        -- complete matchings which, for example, arise from pattern
        -- synonym definitions.
-  | CompleteMatchSig SourceText
+  | CompleteMatchSig (XCompleteMatchSig pass)
+                     SourceText
                      (Located [Located (IdP pass)])
                      (Maybe (Located (IdP pass)))
-
-deriving instance (DataId pass) => Data (Sig pass)
+  | XSig (XXSig pass)
+
+type instance XTypeSig          (GhcPass p) = NoExt
+type instance XPatSynSig        (GhcPass p) = NoExt
+type instance XClassOpSig       (GhcPass p) = NoExt
+type instance XIdSig            (GhcPass p) = NoExt
+type instance XFixSig           (GhcPass p) = NoExt
+type instance XInlineSig        (GhcPass p) = NoExt
+type instance XSpecSig          (GhcPass p) = NoExt
+type instance XSpecInstSig      (GhcPass p) = NoExt
+type instance XMinimalSig       (GhcPass p) = NoExt
+type instance XSCCFunSig        (GhcPass p) = NoExt
+type instance XCompleteMatchSig (GhcPass p) = NoExt
+type instance XXSig             (GhcPass p) = NoExt
 
 -- | Located Fixity Signature
 type LFixitySig pass = Located (FixitySig pass)
 
 -- | Fixity Signature
-data FixitySig pass = FixitySig [Located (IdP pass)] Fixity
-deriving instance (DataId pass) => Data (FixitySig pass)
+data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
+                    | XFixitySig (XXFixitySig pass)
+
+type instance XFixitySig  (GhcPass p) = NoExt
+type instance XXFixitySig (GhcPass p) = NoExt
 
 -- | Type checker Specialisation Pragmas
 --
@@ -950,7 +1088,7 @@ data TcSpecPrag
         Id
         HsWrapper
         InlinePragma
-  -- ^ The Id to be specialised, an wrapper that specialises the
+  -- ^ The Id to be specialised, a wrapper that specialises the
   -- polymorphic function, and inlining spec for the specialised function
   deriving Data
 
@@ -1012,17 +1150,18 @@ isCompleteMatchSig _                            = False
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})           = text "type signature"
 hsSigDoc (PatSynSig {})         = text "pattern synonym signature"
-hsSigDoc (ClassOpSig is_deflt _ _)
+hsSigDoc (ClassOpSig _ is_deflt _ _)
  | is_deflt                     = text "default type signature"
  | otherwise                    = text "class method signature"
 hsSigDoc (IdSig {})             = text "id signature"
 hsSigDoc (SpecSig {})           = text "SPECIALISE pragma"
-hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> text "pragma"
+hsSigDoc (InlineSig _ _ prag)   = ppr (inlinePragmaSpec prag) <+> text "pragma"
 hsSigDoc (SpecInstSig {})       = text "SPECIALISE instance pragma"
 hsSigDoc (FixSig {})            = text "fixity declaration"
 hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"
 hsSigDoc (SCCFunSig {})         = text "SCC pragma"
 hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"
+hsSigDoc (XSig {})              = text "XSIG TTG extension"
 
 {-
 Check if signatures overlap; this is used when checking for duplicate
@@ -1030,46 +1169,48 @@ signatures. Since some of the signatures contain a list of names, testing for
 equality is not enough -- we have to check if they overlap.
 -}
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (Sig pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
     ppr sig = ppr_sig sig
 
-ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
-ppr_sig (TypeSig vars ty)    = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (ClassOpSig is_deflt vars ty)
+ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
+ppr_sig (TypeSig _ vars ty)  = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (ClassOpSig _ is_deflt vars ty)
   | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
   | otherwise                = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig id)           = pprVarSig [id] (ppr (varType id))
-ppr_sig (FixSig fix_sig)     = ppr fix_sig
-ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
+ppr_sig (IdSig _ id)         = pprVarSig [id] (ppr (varType id))
+ppr_sig (FixSig _ fix_sig)   = ppr fix_sig
+ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
   = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
                                              (interpp'SP ty) inl)
     where
       pragmaSrc = case spec of
-        EmptyInlineSpec -> "{-# SPECIALISE"
-        _               -> "{-# SPECIALISE_INLINE"
-ppr_sig (InlineSig var inl)
+        NoUserInline -> "{-# SPECIALISE"
+        _            -> "{-# SPECIALISE_INLINE"
+ppr_sig (InlineSig _ var inl)
   = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl
                                    <+> pprPrefixOcc (unLoc var))
-ppr_sig (SpecInstSig src ty)
+ppr_sig (SpecInstSig _ src ty)
   = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
-ppr_sig (MinimalSig src bf)
+ppr_sig (MinimalSig _ src bf)
   = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
-ppr_sig (PatSynSig names sig_ty)
+ppr_sig (PatSynSig _ names sig_ty)
   = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
-ppr_sig (SCCFunSig src fn mlabel)
+ppr_sig (SCCFunSig _ src fn mlabel)
   = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
-ppr_sig (CompleteMatchSig src cs mty)
+ppr_sig (CompleteMatchSig _ src cs mty)
   = pragSrcBrackets src "{-# COMPLETE"
       ((hsep (punctuate comma (map ppr (unLoc cs))))
         <+> opt_sig)
   where
     opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
+ppr_sig (XSig x) = ppr x
 
-instance OutputableBndrId pass => Outputable (FixitySig pass) where
-  ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (FixitySig p) where
+  ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
     where
       pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
+  ppr (XFixitySig x) = ppr x
 
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
@@ -1112,12 +1253,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
 -}
 
 -- | Haskell Pattern Synonym Details
-data HsPatSynDetails a
-  = InfixPatSyn a a                    -- ^ Infix Pattern Synonym
-  | PrefixPatSyn [a]                   -- ^ Prefix Pattern Synonym
-  | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
-  deriving Data
-
+type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
 
 -- See Note [Record PatSyn Fields]
 -- | Record Pattern Synonym Field
@@ -1174,46 +1310,8 @@ instance Traversable RecordPatSynField where
           <$> f visible <*> f hidden
 
 
-instance Functor HsPatSynDetails where
-    fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
-    fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
-    fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
-
-instance Foldable HsPatSynDetails where
-    foldMap f (InfixPatSyn left right) = f left `mappend` f right
-    foldMap f (PrefixPatSyn args) = foldMap f args
-    foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
-
-    foldl1 f (InfixPatSyn left right) = left `f` right
-    foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
-    foldl1 f (RecordPatSyn args) =
-      Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
-
-    foldr1 f (InfixPatSyn left right) = left `f` right
-    foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
-    foldr1 f (RecordPatSyn args) =
-      Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
-
-    length (InfixPatSyn _ _) = 2
-    length (PrefixPatSyn args) = Data.List.length args
-    length (RecordPatSyn args) = Data.List.length args
-
-    null (InfixPatSyn _ _) = False
-    null (PrefixPatSyn args) = Data.List.null args
-    null (RecordPatSyn args) = Data.List.null args
-
-    toList (InfixPatSyn left right) = [left, right]
-    toList (PrefixPatSyn args) = args
-    toList (RecordPatSyn args) = foldMap toList args
-
-instance Traversable HsPatSynDetails where
-    traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
-    traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
-    traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
-
 -- | Haskell Pattern Synonym Direction
 data HsPatSynDir id
   = Unidirectional
   | ImplicitBidirectional
   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataId id) => Data (HsPatSynDir id)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 8b7d9c6a40..2d2e911645 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -10,7 +10,7 @@
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Abstract syntax of global declarations.
 --
@@ -18,11 +18,11 @@
 -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.
 module HsDecls (
   -- * Toplevel declarations
-  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving,
-  HsDerivingClause(..), LHsDerivingClause,
+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
+  HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
 
   -- ** Class or type declarations
-  TyClDecl(..), LTyClDecl,
+  TyClDecl(..), LTyClDecl, DataDeclRn(..),
   TyClGroup(..), mkTyClGroup, emptyTyClGroup,
   tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
   isClassDecl, isDataDecl, isSynDecl, tcdName,
@@ -35,22 +35,23 @@ module HsDecls (
   FamilyDecl(..), LFamilyDecl,
 
   -- ** Instance declarations
-  InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
+  InstDecl(..), LInstDecl, FamilyInfo(..),
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
-  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
-  TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
+  FamInstEqn, LFamInstEqn, FamEqn(..),
+  TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
   HsTyPats,
   LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
+  -- ** Deriving strategies
+  DerivStrategy(..), LDerivStrategy, derivStrategyName,
   -- ** @RULE@ declarations
-  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr,
+  LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..),
+  RuleBndr(..),LRuleBndr,
   collectRuleBndrSigTys,
   flattenRuleDecls, pprFullRuleName,
-  -- ** @VECTORISE@ declarations
-  VectDecl(..), LVectDecl,
-  lvectDeclName, lvectInstDecl,
   -- ** @default@ declarations
   DefaultDecl(..), LDefaultDecl,
   -- ** Template haskell declaration splice
@@ -58,14 +59,11 @@ module HsDecls (
   SpliceDecl(..), LSpliceDecl,
   -- ** Foreign function interface declarations
   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
-  noForeignImportCoercionYet, noForeignExportCoercionYet,
   CImportSpec(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl,
-  HsConDeclDetails, hsConDeclArgTys,
-  getConNames,
-  getConDetails,
-  gadtDeclDetails,
+  HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
+  getConNames, getConArgs,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -86,7 +84,9 @@ module HsDecls (
     ) where
 
 -- friends:
-import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr,
+import GhcPrelude
+
+import {-# SOURCE #-}   HsExpr( HsExpr, HsSplice, pprExpr,
                                 pprSpliceDecl )
         -- Because Expr imports Decls via HsBracket
 
@@ -94,20 +94,18 @@ import HsBinds
 import HsTypes
 import HsDoc
 import TyCon
-import Name
 import BasicTypes
 import Coercion
 import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
 import HsExtension
 import NameSet
 
 -- others:
-import InstEnv
 import Class
 import Outputable
 import Util
 import SrcLoc
+import Type
 
 import Bag
 import Maybes
@@ -121,7 +119,7 @@ import Data.Data        hiding (TyCon,Fixity, Infix)
 ************************************************************************
 -}
 
-type LHsDecl id = Located (HsDecl id)
+type LHsDecl p = Located (HsDecl p)
         -- ^ When in a list this may have
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
@@ -130,24 +128,37 @@ type LHsDecl id = Located (HsDecl id)
 -- For details on above see note [Api annotations] in ApiAnnotation
 
 -- | A Haskell Declaration
-data HsDecl id
-  = TyClD       (TyClDecl id)      -- ^ Type or Class Declaration
-  | InstD       (InstDecl  id)     -- ^ Instance declaration
-  | DerivD      (DerivDecl id)     -- ^ Deriving declaration
-  | ValD        (HsBind id)        -- ^ Value declaration
-  | SigD        (Sig id)           -- ^ Signature declaration
-  | DefD        (DefaultDecl id)   -- ^ 'default' declaration
-  | ForD        (ForeignDecl id)   -- ^ Foreign declaration
-  | WarningD    (WarnDecls id)     -- ^ Warning declaration
-  | AnnD        (AnnDecl id)       -- ^ Annotation declaration
-  | RuleD       (RuleDecls id)     -- ^ Rule declaration
-  | VectD       (VectDecl id)      -- ^ Vectorise declaration
-  | SpliceD     (SpliceDecl id)    -- ^ Splice declaration
-                                   -- (Includes quasi-quotes)
-  | DocD        (DocDecl)          -- ^ Documentation comment declaration
-  | RoleAnnotD  (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataId id) => Data (HsDecl id)
-
+data HsDecl p
+  = TyClD      (XTyClD p)      (TyClDecl p)      -- ^ Type or Class Declaration
+  | InstD      (XInstD p)      (InstDecl  p)     -- ^ Instance declaration
+  | DerivD     (XDerivD p)     (DerivDecl p)     -- ^ Deriving declaration
+  | ValD       (XValD p)       (HsBind p)        -- ^ Value declaration
+  | SigD       (XSigD p)       (Sig p)           -- ^ Signature declaration
+  | DefD       (XDefD p)       (DefaultDecl p)   -- ^ 'default' declaration
+  | ForD       (XForD p)       (ForeignDecl p)   -- ^ Foreign declaration
+  | WarningD   (XWarningD p)   (WarnDecls p)     -- ^ Warning declaration
+  | AnnD       (XAnnD p)       (AnnDecl p)       -- ^ Annotation declaration
+  | RuleD      (XRuleD p)      (RuleDecls p)     -- ^ Rule declaration
+  | SpliceD    (XSpliceD p)    (SpliceDecl p)    -- ^ Splice declaration
+                                                 -- (Includes quasi-quotes)
+  | DocD       (XDocD p)       (DocDecl)  -- ^ Documentation comment declaration
+  | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration
+  | XHsDecl    (XXHsDecl p)
+
+type instance XTyClD      (GhcPass _) = NoExt
+type instance XInstD      (GhcPass _) = NoExt
+type instance XDerivD     (GhcPass _) = NoExt
+type instance XValD       (GhcPass _) = NoExt
+type instance XSigD       (GhcPass _) = NoExt
+type instance XDefD       (GhcPass _) = NoExt
+type instance XForD       (GhcPass _) = NoExt
+type instance XWarningD   (GhcPass _) = NoExt
+type instance XAnnD       (GhcPass _) = NoExt
+type instance XRuleD      (GhcPass _) = NoExt
+type instance XSpliceD    (GhcPass _) = NoExt
+type instance XDocD       (GhcPass _) = NoExt
+type instance XRoleAnnotD (GhcPass _) = NoExt
+type instance XXHsDecl    (GhcPass _) = NoExt
 
 -- NB: all top-level fixity decls are contained EITHER
 -- EITHER SigDs
@@ -166,50 +177,56 @@ deriving instance (DataId id) => Data (HsDecl id)
 --
 -- A 'HsDecl' is categorised into a 'HsGroup' before being
 -- fed to the renamer.
-data HsGroup id
+data HsGroup p
   = HsGroup {
-        hs_valds  :: HsValBinds id,
-        hs_splcds :: [LSpliceDecl id],
+        hs_ext    :: XCHsGroup p,
+        hs_valds  :: HsValBinds p,
+        hs_splcds :: [LSpliceDecl p],
 
-        hs_tyclds :: [TyClGroup id],
+        hs_tyclds :: [TyClGroup p],
                 -- A list of mutually-recursive groups;
                 -- This includes `InstDecl`s as well;
                 -- Parser generates a singleton list;
                 -- renamer does dependency analysis
 
-        hs_derivds :: [LDerivDecl id],
+        hs_derivds :: [LDerivDecl p],
 
-        hs_fixds  :: [LFixitySig id],
+        hs_fixds  :: [LFixitySig p],
                 -- Snaffled out of both top-level fixity signatures,
                 -- and those in class declarations
 
-        hs_defds  :: [LDefaultDecl id],
-        hs_fords  :: [LForeignDecl id],
-        hs_warnds :: [LWarnDecls id],
-        hs_annds  :: [LAnnDecl id],
-        hs_ruleds :: [LRuleDecls id],
-        hs_vects  :: [LVectDecl id],
+        hs_defds  :: [LDefaultDecl p],
+        hs_fords  :: [LForeignDecl p],
+        hs_warnds :: [LWarnDecls p],
+        hs_annds  :: [LAnnDecl p],
+        hs_ruleds :: [LRuleDecls p],
 
         hs_docs   :: [LDocDecl]
-  }
-deriving instance (DataId id) => Data (HsGroup id)
+    }
+  | XHsGroup (XXHsGroup p)
 
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
+type instance XCHsGroup (GhcPass _) = NoExt
+type instance XXHsGroup (GhcPass _) = NoExt
+
+
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
 hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
 hsGroupInstDecls = (=<<) group_instds . hs_tyclds
 
-emptyGroup = HsGroup { hs_tyclds = [],
+emptyGroup = HsGroup { hs_ext = noExt,
+                       hs_tyclds = [],
                        hs_derivds = [],
                        hs_fixds = [], hs_defds = [], hs_annds = [],
-                       hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
+                       hs_fords = [], hs_warnds = [], hs_ruleds = [],
                        hs_valds = error "emptyGroup hs_valds: Can't happen",
                        hs_splcds = [],
                        hs_docs = [] }
 
-appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
+             -> HsGroup (GhcPass p)
 appendGroups
     HsGroup {
         hs_valds  = val_groups1,
@@ -222,8 +239,7 @@ appendGroups
         hs_fords  = fords1,
         hs_warnds = warnds1,
         hs_ruleds = rulds1,
-        hs_vects = vects1,
-  hs_docs   = docs1 }
+        hs_docs   = docs1 }
     HsGroup {
         hs_valds  = val_groups2,
         hs_splcds = spliceds2,
@@ -235,10 +251,10 @@ appendGroups
         hs_fords  = fords2,
         hs_warnds = warnds2,
         hs_ruleds = rulds2,
-        hs_vects  = vects2,
         hs_docs   = docs2 }
   =
     HsGroup {
+        hs_ext    = noExt,
         hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
         hs_splcds = spliceds1 ++ spliceds2,
         hs_tyclds = tyclds1 ++ tyclds2,
@@ -249,28 +265,26 @@ appendGroups
         hs_fords  = fords1 ++ fords2,
         hs_warnds = warnds1 ++ warnds2,
         hs_ruleds = rulds1 ++ rulds2,
-        hs_vects  = vects1 ++ vects2,
         hs_docs   = docs1  ++ docs2 }
-
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsDecl pass) where
-    ppr (TyClD dcl)             = ppr dcl
-    ppr (ValD binds)            = ppr binds
-    ppr (DefD def)              = ppr def
-    ppr (InstD inst)            = ppr inst
-    ppr (DerivD deriv)          = ppr deriv
-    ppr (ForD fd)               = ppr fd
-    ppr (SigD sd)               = ppr sd
-    ppr (RuleD rd)              = ppr rd
-    ppr (VectD vect)            = ppr vect
-    ppr (WarningD wd)           = ppr wd
-    ppr (AnnD ad)               = ppr ad
-    ppr (SpliceD dd)            = ppr dd
-    ppr (DocD doc)              = ppr doc
-    ppr (RoleAnnotD ra)         = ppr ra
-
-instance (SourceTextX pass, OutputableBndrId pass)
-      => Outputable (HsGroup pass) where
+appendGroups _ _ = panic "appendGroups"
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
+    ppr (TyClD _ dcl)             = ppr dcl
+    ppr (ValD _ binds)            = ppr binds
+    ppr (DefD _ def)              = ppr def
+    ppr (InstD _ inst)            = ppr inst
+    ppr (DerivD _ deriv)          = ppr deriv
+    ppr (ForD _ fd)               = ppr fd
+    ppr (SigD _ sd)               = ppr sd
+    ppr (RuleD _ rd)              = ppr rd
+    ppr (WarningD _ wd)           = ppr wd
+    ppr (AnnD _ ad)               = ppr ad
+    ppr (SpliceD _ dd)            = ppr dd
+    ppr (DocD _ doc)              = ppr doc
+    ppr (RoleAnnotD _ ra)         = ppr ra
+    ppr (XHsDecl x)               = ppr x
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
     ppr (HsGroup { hs_valds  = val_decls,
                    hs_tyclds = tycl_decls,
                    hs_derivds = deriv_decls,
@@ -279,13 +293,11 @@ instance (SourceTextX pass, OutputableBndrId pass)
                    hs_annds  = ann_decls,
                    hs_fords  = foreign_decls,
                    hs_defds  = default_decls,
-                   hs_ruleds = rule_decls,
-                   hs_vects  = vect_decls })
+                   hs_ruleds = rule_decls })
         = vcat_mb empty
             [ppr_ds fix_decls, ppr_ds default_decls,
              ppr_ds deprec_decls, ppr_ds ann_decls,
              ppr_ds rule_decls,
-             ppr_ds vect_decls,
              if isEmptyValBinds val_decls
                 then Nothing
                 else Just (ppr val_decls),
@@ -303,20 +315,26 @@ instance (SourceTextX pass, OutputableBndrId pass)
           vcat_mb _    []             = empty
           vcat_mb gap (Nothing : ds) = vcat_mb gap ds
           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
+    ppr (XHsGroup x) = ppr x
 
 -- | Located Splice Declaration
 type LSpliceDecl pass = Located (SpliceDecl pass)
 
 -- | Splice Declaration
-data SpliceDecl id
+data SpliceDecl p
   = SpliceDecl                  -- Top level splice
-        (Located (HsSplice id))
+        (XSpliceDecl p)
+        (Located (HsSplice p))
         SpliceExplicitFlag
-deriving instance (DataId id) => Data (SpliceDecl id)
+  | XSpliceDecl (XXSpliceDecl p)
+
+type instance XSpliceDecl      (GhcPass _) = NoExt
+type instance XXSpliceDecl     (GhcPass _) = NoExt
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (SpliceDecl pass) where
-   ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (SpliceDecl p) where
+   ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
+   ppr (XSpliceDecl x) = ppr x
 
 {-
 ************************************************************************
@@ -473,7 +491,7 @@ data TyClDecl pass
     --             'ApiAnnotation.AnnVbar'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-    FamDecl { tcdFam :: FamilyDecl pass }
+    FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }
 
   | -- | @type@ declaration
     --
@@ -481,13 +499,13 @@ data TyClDecl pass
     --             'ApiAnnotation.AnnEqual',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-    SynDecl { tcdLName  :: Located (IdP pass)     -- ^ Type constructor
+    SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs
+            , tcdLName  :: Located (IdP pass)     -- ^ Type constructor
             , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an
                                                   -- associated type these
                                                   -- include outer binders
             , tcdFixity :: LexicalFixity    -- ^ Fixity used in the declaration
-            , tcdRhs    :: LHsType pass           -- ^ RHS of type declaration
-            , tcdFVs    :: PostRn pass NameSet }
+            , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration
 
   | -- | @data@ declaration
     --
@@ -498,33 +516,24 @@ data TyClDecl pass
     --              'ApiAnnotation.AnnWhere',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-    DataDecl { tcdLName    :: Located (IdP pass) -- ^ Type constructor
-             , tcdTyVars   :: LHsQTyVars pass  -- ^ Type variables; for an
-                                               -- associated type
-                                               --   these include outer binders
-                                               -- Eg  class T a where
-                                               --       type F a :: *
-                                               --       type F a = a -> a
-                                               -- Here the type decl for 'f'
-                                               -- includes 'a' in its tcdTyVars
-             , tcdFixity  :: LexicalFixity -- ^ Fixity used in the declaration
-             , tcdDataDefn :: HsDataDefn pass
-             , tcdDataCusk :: PostRn pass Bool    -- ^ does this have a CUSK?
-             , tcdFVs      :: PostRn pass NameSet }
-
-  | ClassDecl { tcdCtxt    :: LHsContext pass,         -- ^ Context...
+    DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs
+             , tcdLName    :: Located (IdP pass)   -- ^ Type constructor
+             , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables
+                              -- See Note [TyVar binders for associated declarations]
+             , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration
+             , tcdDataDefn :: HsDataDefn pass }
+
+  | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs
+                tcdCtxt    :: LHsContext pass,         -- ^ Context...
                 tcdLName   :: Located (IdP pass),      -- ^ Name of the class
                 tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables
                 tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration
-                tcdFDs     :: [Located (FunDep (Located (IdP pass)))],
-                                                        -- ^ Functional deps
+                tcdFDs     :: [LHsFunDep pass],         -- ^ Functional deps
                 tcdSigs    :: [LSig pass],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds pass,            -- ^ Default methods
                 tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;
-                tcdATDefs  :: [LTyFamDefltEqn pass],
-                                                   -- ^ Associated type defaults
-                tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
-                tcdFVs     :: PostRn pass NameSet
+                tcdATDefs  :: [LTyFamDefltEqn pass],    -- ^ Associated type defaults
+                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
     }
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',
         --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',
@@ -534,9 +543,51 @@ data TyClDecl pass
         --                          'ApiAnnotation.AnnRarrow'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
+  | XTyClDecl (XXTyClDecl pass)
+
+type LHsFunDep pass = Located (FunDep (Located (IdP pass)))
+
+data DataDeclRn = DataDeclRn
+             { tcdDataCusk :: Bool    -- ^ does this have a CUSK?
+             , tcdFVs      :: NameSet }
+  deriving Data
+
+{- Note [TyVar binders for associated decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For an /associated/ data, newtype, or type-family decl, the LHsQTyVars
+/includes/ outer binders.  For example
+    class T a where
+       data D a c
+       type F a b :: *
+       type F a b = a -> a
+Here the data decl for 'D', and type-family decl for 'F', both include 'a'
+in their LHsQTyVars (tcdTyVars and fdTyVars resp).
+
+Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars.
+
+The idea is that the associated type is really a top-level decl in its
+own right.  However we are careful to use the same name 'a', so that
+we can match things up.
+
+c.f. Note [Associated type tyvar names] in Class.hs
+     Note [Family instance declaration binders]
+-}
+
+type instance XFamDecl      (GhcPass _) = NoExt
 
-deriving instance (DataId id) => Data (TyClDecl id)
+type instance XSynDecl      GhcPs = NoExt
+type instance XSynDecl      GhcRn = NameSet -- FVs
+type instance XSynDecl      GhcTc = NameSet -- FVs
 
+type instance XDataDecl     GhcPs = NoExt
+type instance XDataDecl     GhcRn = DataDeclRn
+type instance XDataDecl     GhcTc = DataDeclRn
+
+type instance XClassDecl    GhcPs = NoExt
+type instance XClassDecl    GhcRn = NameSet -- FVs
+type instance XClassDecl    GhcTc = NameSet -- FVs
+
+type instance XXTyClDecl    (GhcPass _) = NoExt
 
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -564,7 +615,7 @@ isFamilyDecl _other        = False
 
 -- | type family declaration
 isTypeFamilyDecl :: TyClDecl pass -> Bool
-isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
+isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of
   OpenTypeFamily      -> True
   ClosedTypeFamily {} -> True
   _                   -> False
@@ -582,7 +633,7 @@ isClosedTypeFamilyInfo _                     = False
 
 -- | data family declaration
 isDataFamilyDecl :: TyClDecl pass -> Bool
-isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
+isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True
 isDataFamilyDecl _other      = False
 
 -- Dealing with names
@@ -592,8 +643,12 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
 
 tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass)
 tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
-                     (L _ (TyFamEqn { tfe_tycon = ln })) })
+                     (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
   = ln
+tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "tyFamInstDeclLName"
+tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _))
+  = panic "tyFamInstDeclLName"
 
 tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
 tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
@@ -622,7 +677,7 @@ countTyClDecls decls
    isNewTy _                                                      = False
 
 -- | Does this declaration have a complete, user-supplied kind signature?
--- See Note [Complete user-supplied kind signatures]
+-- See Note [CUSKs: complete user-supplied kind signatures]
 hsDeclHasCusk :: TyClDecl GhcRn -> Bool
 hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
 hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
@@ -630,17 +685,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
   = hsTvbAllKinded tyvars && rhs_annotated rhs
   where
     rhs_annotated (L _ ty) = case ty of
-      HsParTy lty  -> rhs_annotated lty
-      HsKindSig {} -> True
-      _            -> False
-hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
+      HsParTy _ lty  -> rhs_annotated lty
+      HsKindSig {}   -> True
+      _              -> False
+hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
 hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
+hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk"
 
 -- Pretty-printing TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (TyClDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
 
     ppr (FamDecl { tcdFam = decl }) = ppr decl
     ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -670,9 +725,10 @@ instance (SourceTextX pass, OutputableBndrId pass)
         top_matter = text "class"
                     <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
                     <+> pprFundeps (map unLoc fds)
+    ppr (XTyClDecl x) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (TyClGroup pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (TyClGroup p) where
   ppr (TyClGroup { group_tyclds = tyclds
                  , group_roles = roles
                  , group_instds = instds
@@ -681,62 +737,121 @@ instance (SourceTextX pass, OutputableBndrId pass)
     = ppr tyclds $$
       ppr roles $$
       ppr instds
+  ppr (XTyClGroup x) = ppr x
 
-pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass)
-   => Located (IdP pass)
-   -> LHsQTyVars pass
+pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
+   => Located (IdP (GhcPass p))
+   -> LHsQTyVars (GhcPass p)
    -> LexicalFixity
-   -> HsContext pass
+   -> HsContext (GhcPass p)
    -> SDoc
 pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
  = hsep [pprHsContext context, pp_tyvars tyvars]
   where
     pp_tyvars (varl:varsr)
+      | fixity == Infix && length varsr > 1
+         = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)
+                , (ppr.unLoc) (head varsr), char ')'
+                , hsep (map (ppr.unLoc) (tail varsr))]
       | fixity == Infix
          = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
          , hsep (map (ppr.unLoc) varsr)]
       | otherwise = hsep [ pprPrefixOcc (unLoc thing)
                   , hsep (map (ppr.unLoc) (varl:varsr))]
-    pp_tyvars [] = ppr thing
+    pp_tyvars [] = pprPrefixOcc (unLoc thing)
+pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x
 
-pprTyClDeclFlavour :: TyClDecl a -> SDoc
+pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
 pprTyClDeclFlavour (ClassDecl {})   = text "class"
 pprTyClDeclFlavour (SynDecl {})     = text "type"
 pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
   = pprFlavour info <+> text "family"
+pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x})
+  = ppr x
 pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
   = ppr nd
+pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
+  = ppr x
+pprTyClDeclFlavour (XTyClDecl x) = ppr x
 
 
-{- Note [Complete user-supplied kind signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [CUSKs: complete user-supplied kind signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We kind-check declarations differently if they have a complete, user-supplied
 kind signature (CUSK). This is because we can safely generalise a CUSKed
 declaration before checking all of the others, supporting polymorphic recursion.
 See ghc.haskell.org/trac/ghc/wiki/GhcKinds/KindInference#Proposednewstrategy
 and #9200 for lots of discussion of how we got here.
 
-A declaration has a CUSK if we can know its complete kind without doing any
-inference, at all. Here are the rules:
-
- - A class or datatype is said to have a CUSK if and only if all of its type
-variables are annotated. Its result kind is, by construction, Constraint or *
-respectively.
-
- - A type synonym has a CUSK if and only if all of its type variables and its
-RHS are annotated with kinds.
-
- - A closed type family is said to have a CUSK if and only if all of its type
-variables and its return type are annotated.
-
- - An open type family always has a CUSK -- unannotated type variables (and
-return type) default to *.
-
- - Additionally, if -XTypeInType is on, then a data definition with a top-level
-   :: must explicitly bind all kind variables to the right of the ::.
-   See test dependent/should_compile/KindLevels, which requires this case.
-   (Naturally, any kind variable mentioned before the :: should not be bound
-   after it.)
+PRINCIPLE:
+  a type declaration has a CUSK iff we could produce a separate kind signature
+  for it, just like a type signature for a function,
+  looking only at the header of the declaration.
+
+Examples:
+  * data T1 (a :: *->*) (b :: *) = ....
+    -- Has CUSK; equivalant to   T1 :: (*->*) -> * -> *
+
+ * data T2 a b = ...
+   -- No CUSK; we do not want to guess T2 :: * -> * -> *
+   -- becuase the full decl might be   data T a b = MkT (a b)
+
+  * data T3 (a :: k -> *) (b :: *) = ...
+    -- CUSK; equivalent to   T3 :: (k -> *) -> * -> *
+    -- We lexically generalise over k to get
+    --    T3 :: forall k. (k -> *) -> * -> *
+    -- The generalisation is here is purely lexical, just like
+    --    f3 :: a -> a
+    -- means
+    --    f3 :: forall a. a -> a
+
+  * data T4 (a :: j k) = ...
+     -- CUSK; equivalent to   T4 :: j k -> *
+     -- which we lexically generalise to  T4 :: forall j k. j k -> *
+     -- and then, if PolyKinds is on, we further generalise to
+     --   T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> *
+     -- Again this is exactly like what happens as the term level
+     -- when you write
+     --    f4 :: forall a b. a b -> Int
+
+NOTE THAT
+  * A CUSK does /not/ mean that everything about the kind signature is
+    fully specified by the user.  Look at T4 and f4: we had do do kind
+    inference to figure out the kind-quantification.  But in both cases
+    (T4 and f4) that inference is done looking /only/ at the header of T4
+    (or signature for f4), not at the definition thereof.
+
+  * The CUSK completely fixes the kind of the type constructor, forever.
+
+  * The precise rules, for each declaration form, for whethher a declaration
+    has a CUSK are given in the user manual section "Complete user-supplied
+    kind signatures and polymorphic recursion".  BUt they simply implement
+    PRINCIPLE above.
+
+  * Open type families are interesting:
+      type family T5 a b :: *
+    There simply /is/ no accompanying declaration, so that info is all
+    we'll ever get.  So we it has a CUSK by definition, and we default
+    any un-fixed kind variables to *.
+
+  * Associated types are a bit tricker:
+      class C6 a where
+         type family T6 a b :: *
+         op :: a Int -> Int
+    Here C6 does not have a CUSK (in fact we ultimately discover that
+    a :: * -> *).  And hence neither does T6, the associated family,
+    because we can't fix its kind until we have settled C6.  Another
+    way to say it: unlike a top-level, we /may/ discover more about
+    a's kind from C6's definition.
+
+  * A data definition with a top-level :: must explicitly bind all
+    kind variables to the right of the ::. See test
+    dependent/should_compile/KindLevels, which requires this
+    case. (Naturally, any kind variable mentioned before the :: should
+    not be bound after it.)
+
+    This last point is much more debatable than the others; see
+    Trac #15142 comment:22
 -}
 
 
@@ -773,13 +888,18 @@ in RnSource for more info.
 
 -- | Type or Class Group
 data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]
-  = TyClGroup { group_tyclds :: [LTyClDecl pass]
+  = TyClGroup { group_ext    :: XCTyClGroup pass
+              , group_tyclds :: [LTyClDecl pass]
               , group_roles  :: [LRoleAnnotDecl pass]
               , group_instds :: [LInstDecl pass] }
-deriving instance (DataId id) => Data (TyClGroup id)
+  | XTyClGroup (XXTyClGroup pass)
 
-emptyTyClGroup :: TyClGroup pass
-emptyTyClGroup = TyClGroup [] [] []
+type instance XCTyClGroup (GhcPass _) = NoExt
+type instance XXTyClGroup (GhcPass _) = NoExt
+
+
+emptyTyClGroup :: TyClGroup (GhcPass p)
+emptyTyClGroup = TyClGroup noExt [] [] []
 
 tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]
 tyClGroupTyClDecls = concatMap group_tyclds
@@ -790,9 +910,11 @@ tyClGroupInstDecls = concatMap group_instds
 tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
 tyClGroupRoleDecls = concatMap group_roles
 
-mkTyClGroup :: [LTyClDecl pass] -> [LInstDecl pass] -> TyClGroup pass
+mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)]
+            -> TyClGroup (GhcPass p)
 mkTyClGroup decls instds = TyClGroup
-  { group_tyclds = decls
+  { group_ext = noExt
+  , group_tyclds = decls
   , group_roles = []
   , group_instds = instds
   }
@@ -873,39 +995,47 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass)
 
 -- | type Family Result Signature
 data FamilyResultSig pass = -- see Note [FamilyResultSig]
-    NoSig
+    NoSig (XNoSig pass)
   -- ^ - 'ApiAnnotation.AnnKeywordId' :
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | KindSig  (LHsKind pass)
+  | KindSig  (XCKindSig pass) (LHsKind pass)
   -- ^ - 'ApiAnnotation.AnnKeywordId' :
   --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
   --             'ApiAnnotation.AnnCloseP'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | TyVarSig (LHsTyVarBndr pass)
+  | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass)
   -- ^ - 'ApiAnnotation.AnnKeywordId' :
   --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
   --             'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'
+  | XFamilyResultSig (XXFamilyResultSig pass)
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId pass) => Data (FamilyResultSig pass)
+type instance XNoSig            (GhcPass _) = NoExt
+type instance XCKindSig         (GhcPass _) = NoExt
+type instance XTyVarSig         (GhcPass _) = NoExt
+type instance XXFamilyResultSig (GhcPass _) = NoExt
+
 
 -- | Located type Family Declaration
 type LFamilyDecl pass = Located (FamilyDecl pass)
 
 -- | type Family Declaration
 data FamilyDecl pass = FamilyDecl
-  { fdInfo           :: FamilyInfo pass              -- type/data, closed/open
+  { fdExt            :: XCFamilyDecl pass
+  , fdInfo           :: FamilyInfo pass              -- type/data, closed/open
   , fdLName          :: Located (IdP pass)           -- type constructor
   , fdTyVars         :: LHsQTyVars pass              -- type variables
-  , fdFixity         :: LexicalFixity         -- Fixity used in the declaration
+                       -- See Note [TyVar binders for associated declarations]
+  , fdFixity         :: LexicalFixity                -- Fixity used in the declaration
   , fdResultSig      :: LFamilyResultSig pass        -- result signature
   , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann
   }
+  | XFamilyDecl (XXFamilyDecl pass)
   -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
   --             'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',
   --             'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',
@@ -915,7 +1045,9 @@ data FamilyDecl pass = FamilyDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId id) => Data (FamilyDecl id)
+type instance XCFamilyDecl    (GhcPass _) = NoExt
+type instance XXFamilyDecl    (GhcPass _) = NoExt
+
 
 -- | Located Injectivity Annotation
 type LInjectivityAnn pass = Located (InjectivityAnn pass)
@@ -934,7 +1066,6 @@ data InjectivityAnn pass
   --             'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (InjectivityAnn pass)
 
 data FamilyInfo pass
   = DataFamily
@@ -942,9 +1073,9 @@ data FamilyInfo pass
      -- | 'Nothing' if we're in an hs-boot file and the user
      -- said "type family Foo x where .."
   | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-deriving instance (DataId pass) => Data (FamilyInfo pass)
 
 -- | Does this family declaration have a complete, user-supplied kind signature?
+-- See Note [CUSKs: complete user-supplied kind signatures]
 famDeclHasCusk :: Maybe Bool
                    -- ^ if associated, does the enclosing class have a CUSK?
                -> FamilyDecl pass -> Bool
@@ -953,25 +1084,25 @@ famDeclHasCusk _ (FamilyDecl { fdInfo      = ClosedTypeFamily _
                              , fdResultSig = L _ resultSig })
   = hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
 famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-        -- all un-associated open families have CUSKs!
+        -- all un-associated open families have CUSKs
 
 -- | Does this family declaration have user-supplied return kind signature?
 hasReturnKindSignature :: FamilyResultSig a -> Bool
-hasReturnKindSignature NoSig                          = False
-hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
-hasReturnKindSignature _                              = True
+hasReturnKindSignature (NoSig _)                        = False
+hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False
+hasReturnKindSignature _                                = True
 
 -- | Maybe return name of the result type variable
 resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
-resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
-resultVariableName _              = Nothing
+resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig
+resultVariableName _                = Nothing
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (FamilyDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (FamilyDecl p) where
   ppr = pprFamilyDecl TopLevel
 
-pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass)
-              => TopLevelFlag -> FamilyDecl pass -> SDoc
+pprFamilyDecl :: (OutputableBndrId (GhcPass p))
+              => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
 pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                                     , fdTyVars = tyvars
                                     , fdFixity = fixity
@@ -987,9 +1118,10 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                      NotTopLevel -> empty
 
     pp_kind = case result of
-                NoSig            -> empty
-                KindSig  kind    -> dcolon <+> ppr kind
-                TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr
+                NoSig    _         -> empty
+                KindSig  _ kind    -> dcolon <+> ppr kind
+                TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
+                XFamilyResultSig x -> ppr x
     pp_inj = case mb_inj of
                Just (L _ (InjectivityAnn lhs rhs)) ->
                  hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
@@ -999,8 +1131,9 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
         ( text "where"
         , case mb_eqns of
             Nothing   -> text ".."
-            Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
+            Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
       _ -> (empty, empty)
+pprFamilyDecl _ (XFamilyDecl x) = ppr x
 
 pprFlavour :: FamilyInfo pass -> SDoc
 pprFlavour DataFamily            = text "data"
@@ -1027,7 +1160,8 @@ data HsDataDefn pass   -- The payload of a data type defn
     --  data/newtype T a = <constrs>
     --  data/newtype instance T [a] = <constrs>
     -- @
-    HsDataDefn { dd_ND     :: NewOrData,
+    HsDataDefn { dd_ext    :: XCHsDataDefn pass,
+                 dd_ND     :: NewOrData,
                  dd_ctxt   :: LHsContext pass,           -- ^ Context
                  dd_cType  :: Maybe (Located CType),
                  dd_kindSig:: Maybe (LHsKind pass),
@@ -1050,7 +1184,10 @@ data HsDataDefn pass   -- The payload of a data type defn
 
              -- For details on above see note [Api annotations] in ApiAnnotation
    }
-deriving instance (DataId id) => Data (HsDataDefn id)
+  | XHsDataDefn (XXHsDataDefn pass)
+
+type instance XCHsDataDefn    (GhcPass _) = NoExt
+type instance XXHsDataDefn    (GhcPass _) = NoExt
 
 -- | Haskell Deriving clause
 type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1073,7 +1210,8 @@ type LHsDerivingClause pass = Located (HsDerivingClause pass)
 data HsDerivingClause pass
   -- See Note [Deriving strategies] in TcDeriv
   = HsDerivingClause
-    { deriv_clause_strategy :: Maybe (Located DerivStrategy)
+    { deriv_clause_ext :: XCHsDerivingClause pass
+    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
       -- ^ The user-specified strategy (if any) to use when deriving
       -- 'deriv_clause_tys'.
     , deriv_clause_tys :: Located [LHsSigType pass]
@@ -1086,28 +1224,45 @@ data HsDerivingClause pass
       --
       -- should produce a derived instance for @C [a] (T b)@.
     }
-deriving instance (DataId id) => Data (HsDerivingClause id)
+  | XHsDerivingClause (XXHsDerivingClause pass)
+
+type instance XCHsDerivingClause    (GhcPass _) = NoExt
+type instance XXHsDerivingClause    (GhcPass _) = NoExt
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsDerivingClause pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (HsDerivingClause p) where
   ppr (HsDerivingClause { deriv_clause_strategy = dcs
                         , deriv_clause_tys      = L _ dct })
     = hsep [ text "deriving"
-           , ppDerivStrategy dcs
-           , pp_dct dct ]
+           , pp_strat_before
+           , pp_dct dct
+           , pp_strat_after ]
       where
         -- This complexity is to distinguish between
         --    deriving Show
         --    deriving (Show)
-        pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)
-        pp_dct [a] = ppr a
-        pp_dct _   = parens (interpp'SP dct)
+        pp_dct [HsIB { hsib_body = ty }]
+                 = ppr (parenthesizeHsType appPrec ty)
+        pp_dct _ = parens (interpp'SP dct)
+
+        -- @via@ is unique in that in comes /after/ the class being derived,
+        -- so we must special-case it.
+        (pp_strat_before, pp_strat_after) =
+          case dcs of
+            Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
+            _                            -> (ppDerivStrategy dcs, empty)
+  ppr (XHsDerivingClause x) = ppr x
 
 data NewOrData
   = NewType                     -- ^ @newtype Blah ...@
   | DataType                    -- ^ @data Blah ...@
   deriving( Eq, Data )                -- Needed because Demand derives Eq
 
+-- | Convert a 'NewOrData' to a 'TyConFlavour'
+newOrDataToFlavour :: NewOrData -> TyConFlavour
+newOrDataToFlavour NewType  = NewtypeFlavour
+newOrDataToFlavour DataType = DataTypeFlavour
+
 -- | Located data Constructor Declaration
 type LConDecl pass = Located (ConDecl pass)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when
@@ -1142,33 +1297,85 @@ type LConDecl pass = Located (ConDecl pass)
 -- | data Constructor Declaration
 data ConDecl pass
   = ConDeclGADT
-      { con_names   :: [Located (IdP pass)]
-      , con_type    :: LHsSigType pass
-        -- ^ The type after the ‘::’
+      { con_g_ext   :: XConDeclGADT pass
+      , con_names   :: [Located (IdP pass)]
+
+      -- The next four fields describe the type after the '::'
+      -- See Note [GADT abstract syntax]
+      -- The following field is Located to anchor API Annotations,
+      -- AnnForall and AnnDot.
+      , con_forall  :: Located Bool      -- ^ True <=> explicit forall
+                                         --   False => hsq_explicit is empty
+      , con_qvars   :: LHsQTyVars pass
+                       -- Whether or not there is an /explicit/ forall, we still
+                       -- need to capture the implicitly-bound type/kind variables
+
+      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon
+      , con_res_ty  :: LHsType pass            -- ^ Result type
+
       , con_doc     :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
 
   | ConDeclH98
-      { con_name    :: Located (IdP pass)
-
-      , con_qvars     :: Maybe (LHsQTyVars pass)
-        -- User-written forall (if any), and its implicit
-        -- kind variables
-        -- Non-Nothing needs -XExistentialQuantification
-        --               e.g. data T a = forall b. MkT b (b->a)
-        --               con_qvars = {b}
-
-      , con_cxt       :: Maybe (LHsContext pass)
-        -- ^ User-written context (if any)
-
-      , con_details   :: HsConDeclDetails pass
-          -- ^ Arguments
+      { con_ext     :: XConDeclH98 pass
+      , con_name    :: Located (IdP pass)
+
+      , con_forall  :: Located Bool
+                              -- ^ True <=> explicit user-written forall
+                              --     e.g. data T a = forall b. MkT b (b->a)
+                              --     con_ex_tvs = {b}
+                              -- False => con_ex_tvs is empty
+      , con_ex_tvs :: [LHsTyVarBndr pass]      -- ^ Existentials only
+      , con_mb_cxt :: Maybe (LHsContext pass)  -- ^ User-written context (if any)
+      , con_args   :: HsConDeclDetails pass    -- ^ Arguments; can be InfixCon
 
       , con_doc       :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
-deriving instance (DataId pass) => Data (ConDecl pass)
+  | XConDecl (XXConDecl pass)
+
+type instance XConDeclGADT (GhcPass _) = NoExt
+type instance XConDeclH98  (GhcPass _) = NoExt
+type instance XXConDecl    (GhcPass _) = NoExt
+
+{- Note [GADT abstract syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's a wrinkle in ConDeclGADT
+
+* For record syntax, it's all uniform.  Given:
+      data T a where
+        K :: forall a. Ord a => { x :: [a], ... } -> T a
+    we make the a ConDeclGADT for K with
+       con_qvars  = {a}
+       con_mb_cxt = Just [Ord a]
+       con_args   = RecCon <the record fields>
+       con_res_ty = T a
+
+  We need the RecCon before the reanmer, so we can find the record field
+  binders in HsUtils.hsConDeclsBinders.
+
+* However for a GADT constr declaration which is not a record, it can
+  be hard parse until we know operator fixities. Consider for example
+     C :: a :*: b -> a :*: b -> a :+: b
+  Initially this type will parse as
+      a :*: (b -> (a :*: (b -> (a :+: b))))
+  so it's hard to split up the arguments until we've done the precedence
+  resolution (in the renamer).
+
+  So:  - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr
+         type into the res_ty for a ConDeclGADT for now, and use
+         PrefixCon []
+            con_args   = PrefixCon []
+            con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b))))
+
+       - In the renamer (RnSource.rnConDecl), we unravel it afer
+         operator fixities are sorted. So we generate. So we end
+         up with
+            con_args   = PrefixCon [ a :*: b, a :*: b ]
+            con_res_ty = a :+: b
+-}
 
 -- | Haskell data Constructor Declaration Details
 type HsConDeclDetails pass
@@ -1177,37 +1384,23 @@ type HsConDeclDetails pass
 getConNames :: ConDecl pass -> [Located (IdP pass)]
 getConNames ConDeclH98  {con_name  = name}  = [name]
 getConNames ConDeclGADT {con_names = names} = names
+getConNames XConDecl {} = panic "getConNames"
 
--- don't call with RdrNames, because it can't deal with HsAppsTy
-getConDetails :: ConDecl pass -> HsConDeclDetails pass
-getConDetails ConDeclH98  {con_details  = details} = details
-getConDetails ConDeclGADT {con_type     = ty     } = details
-  where
-    (details,_,_,_) = gadtDeclDetails ty
-
--- don't call with RdrNames, because it can't deal with HsAppsTy
-gadtDeclDetails :: LHsSigType pass
-                -> ( HsConDeclDetails pass
-                   , LHsType pass
-                   , LHsContext pass
-                   , [LHsTyVarBndr pass] )
-gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
-  where
-    (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
-    (details, res_ty)           -- See Note [Sorting out the result type]
-      = case tau of
-          L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
-                  -> (RecCon (L l flds), res_ty')
-          _other  -> (PrefixCon [], tau)
+getConArgs :: ConDecl pass -> HsConDeclDetails pass
+getConArgs d = con_args d
 
 hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]
 hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
-pp_data_defn :: (SourceTextX pass, OutputableBndrId pass)
-                  => (HsContext pass -> SDoc)   -- Printing the header
-                  -> HsDataDefn pass
+hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
+hsConDeclTheta Nothing            = []
+hsConDeclTheta (Just (L _ theta)) = theta
+
+pp_data_defn :: (OutputableBndrId (GhcPass p))
+                  => (HsContext (GhcPass p) -> SDoc)   -- Printing the header
+                  -> HsDataDefn (GhcPass p)
                   -> SDoc
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                                 , dd_cType = mb_ct
@@ -1228,48 +1421,57 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
                Nothing   -> empty
                Just kind -> dcolon <+> ppr kind
     pp_derivings (L _ ds) = vcat (map ppr ds)
+pp_data_defn _ (XHsDataDefn x) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsDataDefn pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (HsDataDefn p) where
    ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
 
 instance Outputable NewOrData where
   ppr NewType  = text "newtype"
   ppr DataType = text "data"
 
-pp_condecls :: (SourceTextX pass, OutputableBndrId pass)
-            => [LConDecl pass] -> SDoc
+pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc
 pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
   = hang (text "where") 2 (vcat (map ppr cs))
 pp_condecls cs                    -- In H98 syntax
   = equals <+> sep (punctuate (text " |") (map ppr cs))
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (ConDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where
     ppr = pprConDecl
 
-pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
+pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc
 pprConDecl (ConDeclH98 { con_name = L _ con
-                       , con_qvars = mtvs
-                       , con_cxt = mcxt
-                       , con_details = details
+                       , con_ex_tvs = ex_tvs
+                       , con_mb_cxt = mcxt
+                       , con_args = args
                        , con_doc = doc })
-  = sep [ppr_mbDoc doc, pprHsForAll tvs cxt,         ppr_details details]
+  = sep [ppr_mbDoc doc, pprHsForAll ex_tvs cxt, ppr_details args]
   where
     ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
     ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprHsType . unLoc) tys)
     ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
-    tvs = case mtvs of
-      Nothing -> []
-      Just (HsQTvs { hsq_explicit = tvs }) -> tvs
+    cxt = fromMaybe (noLoc []) mcxt
+
+pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
+                        , con_mb_cxt = mcxt, con_args = args
+                        , con_res_ty = res_ty, con_doc = doc })
+  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
+    <+> (sep [pprHsForAll (hsq_explicit qvars) cxt,
+              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
+  where
+    get_args (PrefixCon args) = map ppr args
+    get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]
+    get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)
 
     cxt = fromMaybe (noLoc []) mcxt
 
-pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc })
-  = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
-         <+> ppr res_ty]
+    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
+    ppr_arrow_chain []     = empty
+
+pprConDecl (XConDecl x) = ppr x
 
 ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
 ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
@@ -1283,27 +1485,35 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
 Note [Type family instance declarations in HsSyn]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The data type TyFamEqn represents one equation of a type family instance.
-It is parameterised over its tfe_pats field:
+The data type FamEqn represents one equation of a type family instance.
+Aside from the pass, it is also parameterised over two fields:
+feqn_pats and feqn_rhs.
+
+feqn_pats is either LHsTypes (for ordinary data/type family instances) or
+LHsQTyVars (for associated type family default instances). In particular:
 
  * An ordinary type family instance declaration looks like this in source Haskell
       type instance T [a] Int = a -> a
    (or something similar for a closed family)
-   It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
+   It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats
+   field.
 
  * On the other hand, the *default instance* of an associated type looks like
    this in source Haskell
       class C a where
         type T a b
         type T a b = a -> b   -- The default instance
-   It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats
-   field.
+   It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in
+   the feqn_pats field.
+
+feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType
+(for type family instances).
 -}
 
 ----------------- Type synonym family instances -------------
 
 -- | Located Type Family Instance Equation
-type LTyFamInstEqn  pass = Located (TyFamInstEqn  pass)
+type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
   -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
   --   when in a list
 
@@ -1313,16 +1523,14 @@ type LTyFamInstEqn  pass = Located (TyFamInstEqn  pass)
 type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
 
 -- | Haskell Type Patterns
-type HsTyPats pass = HsImplicitBndrs pass [LHsType pass]
-            -- ^ Type patterns (with kind and type bndrs)
-            -- See Note [Family instance declaration binders]
+type HsTyPats pass = [LHsType pass]
 
 {- Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The HsTyPats field is LHS patterns or a type/data family instance.
-
-The hsib_vars of the HsImplicitBndrs are the template variables of the
-type patterns, i.e. fv(pat_tys).  Note in particular
+For ordinary data/type family instances, the feqn_pats field of FamEqn stores
+the LHS type (and kind) patterns. These type patterns can of course contain
+type (and kind) variables, which are bound in the hsib_vars field of the
+HsImplicitBndrs in FamInstEqn. Note in particular
 
 * The hsib_vars *includes* any anonymous wildcards.  For example
      type instance F a _ = a
@@ -1330,7 +1538,7 @@ type patterns, i.e. fv(pat_tys).  Note in particular
   '_' gets its own unique.  In this context wildcards behave just like
   an ordinary type variable, only anonymous.
 
-* The hsib_vars *including* type variables that are already in scope
+* The hsib_vars *includes* type variables that are already in scope
 
    Eg   class C s t where
           type F t p :: *
@@ -1344,45 +1552,31 @@ type patterns, i.e. fv(pat_tys).  Note in particular
           type F (a8,b9) x10 = x10->a8
    so that we can compare the type pattern in the 'instance' decl and
    in the associated 'type' decl
+
+For associated type family default instances (TyFamDefltEqn), instead of using
+type patterns with binders in a surrounding HsImplicitBndrs, we use raw type
+variables (LHsQTyVars) in the feqn_pats field of FamEqn.
+
+c.f. Note [TyVar binders for associated declarations]
 -}
 
 -- | Type Family Instance Equation
-type TyFamInstEqn  pass = TyFamEqn pass (HsTyPats pass)
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
 
 -- | Type Family Default Equation
-type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass)
+type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
   -- See Note [Type family instance declarations in HsSyn]
 
--- | Type Family Equation
---
--- One equation in a type family instance declaration
--- See Note [Type family instance declarations in HsSyn]
-data TyFamEqn pass pats
-  = TyFamEqn
-       { tfe_tycon  :: Located (IdP pass)
-       , tfe_pats   :: pats
-       , tfe_fixity :: LexicalFixity    -- ^ Fixity used in the declaration
-       , tfe_rhs    :: LHsType pass }
-    -- ^
-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-
-    -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats)
-
 -- | Located Type Family Instance Declaration
 type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
 
 -- | Type Family Instance Declaration
-data TyFamInstDecl pass
-  = TyFamInstDecl
-       { tfid_eqn  :: LTyFamInstEqn pass
-       , tfid_fvs  :: PostRn pass NameSet }
+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --           'ApiAnnotation.AnnInstance',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (TyFamInstDecl pass)
 
 ----------------- Data family instances -------------
 
@@ -1390,14 +1584,8 @@ deriving instance (DataId pass) => Data (TyFamInstDecl pass)
 type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
 
 -- | Data Family Instance Declaration
-data DataFamInstDecl pass
-  = DataFamInstDecl
-       { dfid_tycon     :: Located (IdP pass)
-       , dfid_pats      :: HsTyPats   pass       -- LHS
-       , dfid_fixity    :: LexicalFixity    -- ^ Fixity used in the declaration
-       , dfid_defn      :: HsDataDefn pass       -- RHS
-       , dfid_fvs       :: PostRn pass NameSet }
-                                           -- Free vars for dependency analysis
+newtype DataFamInstDecl pass
+  = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
@@ -1406,8 +1594,40 @@ data DataFamInstDecl pass
     --           'ApiAnnotation.AnnClose'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DataFamInstDecl pass)
 
+----------------- Family instances (common types) -------------
+
+-- | Located Family Instance Equation
+type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
+
+-- | Family Instance Equation
+type FamInstEqn pass rhs
+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+            -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
+            -- See Note [Family instance declaration binders]
+
+-- | Family Equation
+--
+-- One equation in a type family instance declaration, data family instance
+-- declaration, or type family default.
+-- See Note [Type family instance declarations in HsSyn]
+-- See Note [Family instance declaration binders]
+data FamEqn pass pats rhs
+  = FamEqn
+       { feqn_ext    :: XCFamEqn pass pats rhs
+       , feqn_tycon  :: Located (IdP pass)
+       , feqn_pats   :: pats
+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+       , feqn_rhs    :: rhs
+       }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
+  | XFamEqn (XXFamEqn pass pats rhs)
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
+
+type instance XCFamEqn    (GhcPass _) p r = NoExt
+type instance XXFamEqn    (GhcPass _) p r = NoExt
 
 ----------------- Class instances -------------
 
@@ -1417,7 +1637,8 @@ type LClsInstDecl pass = Located (ClsInstDecl pass)
 -- | Class Instance Declaration
 data ClsInstDecl pass
   = ClsInstDecl
-      { cid_poly_ty :: LHsSigType pass    -- Context => Class Instance-type
+      { cid_ext     :: XCClsInstDecl pass
+      , cid_poly_ty :: LHsSigType pass    -- Context => Class Instance-type
                                           -- Using a polytype means that the renamer conveniently
                                           -- figures out the quantified type variables for us.
       , cid_binds         :: LHsBinds pass       -- Class methods
@@ -1436,8 +1657,10 @@ data ClsInstDecl pass
     --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (ClsInstDecl id)
+  | XClsInstDecl (XXClsInstDecl pass)
 
+type instance XCClsInstDecl    (GhcPass _) = NoExt
+type instance XXClsInstDecl    (GhcPass _) = NoExt
 
 ----------------- Instances of all kinds -------------
 
@@ -1447,19 +1670,27 @@ type LInstDecl pass = Located (InstDecl pass)
 -- | Instance Declaration
 data InstDecl pass  -- Both class and family instances
   = ClsInstD
-      { cid_inst  :: ClsInstDecl pass }
+      { cid_d_ext :: XClsInstD pass
+      , cid_inst  :: ClsInstDecl pass }
   | DataFamInstD              -- data family instance
-      { dfid_inst :: DataFamInstDecl pass }
+      { dfid_ext  :: XDataFamInstD pass
+      , dfid_inst :: DataFamInstDecl pass }
   | TyFamInstD              -- type family instance
-      { tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataId id) => Data (InstDecl id)
+      { tfid_ext  :: XTyFamInstD pass
+      , tfid_inst :: TyFamInstDecl pass }
+  | XInstDecl (XXInstDecl pass)
+
+type instance XClsInstD     (GhcPass _) = NoExt
+type instance XDataFamInstD (GhcPass _) = NoExt
+type instance XTyFamInstD   (GhcPass _) = NoExt
+type instance XXInstDecl    (GhcPass _) = NoExt
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (TyFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (TyFamInstDecl p) where
   ppr = pprTyFamInstDecl TopLevel
 
-pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
-                 => TopLevelFlag -> TyFamInstDecl pass -> SDoc
+pprTyFamInstDecl :: (OutputableBndrId (GhcPass p))
+                 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
 pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
    = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
 
@@ -1467,51 +1698,71 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
 ppr_instance_keyword TopLevel    = text "instance"
 ppr_instance_keyword NotTopLevel = empty
 
-ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
-                 => LTyFamInstEqn pass -> SDoc
-ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
-                                , tfe_pats  = pats
-                                , tfe_fixity = fixity
-                                , tfe_rhs   = rhs }))
-    = pp_fam_inst_lhs tycon pats fixity [] <+> equals <+> ppr rhs
-
-ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
-                  => LTyFamDefltEqn pass -> SDoc
-ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
-                                 , tfe_pats  = tvs
-                                 , tfe_fixity = fixity
-                                 , tfe_rhs   = rhs }))
+ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
+                 => TyFamInstEqn (GhcPass p) -> SDoc
+ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                                            , feqn_pats   = pats
+                                            , feqn_fixity = fixity
+                                            , feqn_rhs    = rhs }})
+    = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
+ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
+ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
+
+ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p))
+                  => LTyFamDefltEqn (GhcPass p) -> SDoc
+ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon  = tycon
+                               , feqn_pats   = tvs
+                               , feqn_fixity = fixity
+                               , feqn_rhs    = rhs }))
     = text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
                   <+> equals <+> ppr rhs
+ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (DataFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (DataFamInstDecl p) where
   ppr = pprDataFamInstDecl TopLevel
 
-pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
-                   => TopLevelFlag -> DataFamInstDecl pass -> SDoc
-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
-                                            , dfid_pats  = pats
-                                            , dfid_fixity = fixity
-                                            , dfid_defn  = defn })
+pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
+                   => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                             FamEqn { feqn_tycon  = tycon
+                                    , feqn_pats   = pats
+                                    , feqn_fixity = fixity
+                                    , feqn_rhs    = defn }}})
   = pp_data_defn pp_hdr defn
   where
     pp_hdr ctxt = ppr_instance_keyword top_lvl
-              <+> pp_fam_inst_lhs tycon pats fixity ctxt
-
-pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc
-pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+              <+> pprFamInstLHS tycon pats fixity ctxt Nothing
+                    -- No need to pass an explicit kind signature to
+                    -- pprFamInstLHS here, since pp_data_defn already
+                    -- pretty-prints that. See #14817.
+pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
+  = ppr x
+pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
+  = ppr x
+
+pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                        FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
   = ppr nd
-
-pp_fam_inst_lhs :: (SourceTextX pass, OutputableBndrId pass)
-   => Located (IdP pass)
-   -> HsTyPats pass
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                        FamEqn { feqn_rhs = XHsDataDefn x}}})
+  = ppr x
+pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
+  = ppr x
+pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
+  = ppr x
+
+pprFamInstLHS :: (OutputableBndrId (GhcPass p))
+   => Located (IdP (GhcPass p))
+   -> HsTyPats (GhcPass p)
    -> LexicalFixity
-   -> HsContext pass
+   -> HsContext (GhcPass p)
+   -> Maybe (LHsKind (GhcPass p))
    -> SDoc
-pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
+pprFamInstLHS thing typats fixity context mb_kind_sig
                                               -- explicit type patterns
-   = hsep [ pprHsContext context, pp_pats typats]
+   = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
    where
      pp_pats (patl:patsr)
        | fixity == Infix
@@ -1519,10 +1770,16 @@ pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) fixity context
           , hsep (map (pprHsType.unLoc) patsr)]
        | otherwise = hsep [ pprPrefixOcc (unLoc thing)
                    , hsep (map (pprHsType.unLoc) (patl:patsr))]
-     pp_pats [] = empty
+     pp_pats [] = pprPrefixOcc (unLoc thing)
+
+     pp_kind_sig
+       | Just k <- mb_kind_sig
+       = dcolon <+> ppr k
+       | otherwise
+       = empty
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (ClsInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (ClsInstDecl p) where
     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
                      , cid_sigs = sigs, cid_tyfam_insts = ats
                      , cid_overlap_mode = mbOverlap
@@ -1539,8 +1796,10 @@ instance (SourceTextX pass, OutputableBndrId pass)
       where
         top_matter = text "instance" <+> ppOverlapPragma mbOverlap
                                              <+> ppr inst_ty
+    ppr (XClsInstDecl x) = ppr x
 
-ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc
+ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p)
+                => Maybe (LDerivStrategy p) -> SDoc
 ppDerivStrategy mb =
   case mb of
     Nothing       -> empty
@@ -1560,11 +1819,11 @@ ppOverlapPragma mb =
     maybe_stext (SourceText src) _   = text src <+> text "#-}"
 
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (InstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where
     ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
     ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl
     ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
+    ppr (XInstDecl x) = ppr x
 
 -- Extract the declarations of associated data types from an instance
 
@@ -1576,6 +1835,8 @@ instDeclDataFamInsts inst_decls
       = map unLoc fam_insts
     do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]
     do_one (L _ (TyFamInstD {}))                              = []
+    do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts"
+    do_one (L _ (XInstDecl _))                 = panic "instDeclDataFamInsts"
 
 {-
 ************************************************************************
@@ -1585,13 +1846,25 @@ instDeclDataFamInsts inst_decls
 ************************************************************************
 -}
 
--- | Located Deriving Declaration
+-- | Located stand-alone 'deriving instance' declaration
 type LDerivDecl pass = Located (DerivDecl pass)
 
--- | Deriving Declaration
+-- | Stand-alone 'deriving instance' declaration
 data DerivDecl pass = DerivDecl
-        { deriv_type         :: LHsSigType pass
-        , deriv_strategy     :: Maybe (Located DerivStrategy)
+        { deriv_ext          :: XCDerivDecl pass
+        , deriv_type         :: LHsSigWcType pass
+          -- ^ The instance type to derive.
+          --
+          -- It uses an 'LHsSigWcType' because the context is allowed to be a
+          -- single wildcard:
+          --
+          -- > deriving instance _ => Eq (Foo a)
+          --
+          -- Which signifies that the context should be inferred.
+
+          -- See Note [Inferring the instance context] in TcDerivInfer.
+
+        , deriv_strategy     :: Maybe (LDerivStrategy pass)
         , deriv_overlap_mode :: Maybe (Located OverlapMode)
          -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
          --        'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
@@ -1600,10 +1873,13 @@ data DerivDecl pass = DerivDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
         }
-deriving instance (DataId pass) => Data (DerivDecl pass)
+  | XDerivDecl (XXDerivDecl pass)
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (DerivDecl pass) where
+type instance XCDerivDecl    (GhcPass _) = NoExt
+type instance XXDerivDecl    (GhcPass _) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (DerivDecl p) where
     ppr (DerivDecl { deriv_type = ty
                    , deriv_strategy = ds
                    , deriv_overlap_mode = o })
@@ -1612,6 +1888,51 @@ instance (SourceTextX pass, OutputableBndrId pass)
                , text "instance"
                , ppOverlapPragma o
                , ppr ty ]
+    ppr (XDerivDecl x) = ppr x
+
+{-
+************************************************************************
+*                                                                      *
+                Deriving strategies
+*                                                                      *
+************************************************************************
+-}
+
+-- | A 'Located' 'DerivStrategy'.
+type LDerivStrategy pass = Located (DerivStrategy pass)
+
+-- | Which technique the user explicitly requested when deriving an instance.
+data DerivStrategy pass
+  -- See Note [Deriving strategies] in TcDeriv
+  = StockStrategy    -- ^ GHC's \"standard\" strategy, which is to implement a
+                     --   custom instance for the data type. This only works
+                     --   for certain types that GHC knows about (e.g., 'Eq',
+                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,
+                     --   etc.)
+  | AnyclassStrategy -- ^ @-XDeriveAnyClass@
+  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@
+  | ViaStrategy (XViaStrategy pass)
+                     -- ^ @-XDerivingVia@
+
+type instance XViaStrategy GhcPs = LHsSigType GhcPs
+type instance XViaStrategy GhcRn = LHsSigType GhcRn
+type instance XViaStrategy GhcTc = Type
+
+instance (p ~ GhcPass pass, OutputableBndrId p)
+        => Outputable (DerivStrategy p) where
+    ppr StockStrategy    = text "stock"
+    ppr AnyclassStrategy = text "anyclass"
+    ppr NewtypeStrategy  = text "newtype"
+    ppr (ViaStrategy ty) = text "via" <+> ppr ty
+
+-- | A short description of a @DerivStrategy'@.
+derivStrategyName :: DerivStrategy a -> SDoc
+derivStrategyName = text . go
+  where
+    go StockStrategy    = "stock"
+    go AnyclassStrategy = "anyclass"
+    go NewtypeStrategy  = "newtype"
+    go (ViaStrategy {}) = "via"
 
 {-
 ************************************************************************
@@ -1630,18 +1951,21 @@ type LDefaultDecl pass = Located (DefaultDecl pass)
 
 -- | Default Declaration
 data DefaultDecl pass
-  = DefaultDecl [LHsType pass]
+  = DefaultDecl (XCDefaultDecl pass) [LHsType pass]
         -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',
         --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DefaultDecl pass)
+  | XDefaultDecl (XXDefaultDecl pass)
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (DefaultDecl pass) where
+type instance XCDefaultDecl    (GhcPass _) = NoExt
+type instance XXDefaultDecl    (GhcPass _) = NoExt
 
-    ppr (DefaultDecl tys)
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (DefaultDecl p) where
+    ppr (DefaultDecl _ tys)
       = text "default" <+> parens (interpp'SP tys)
+    ppr (XDefaultDecl x) = ppr x
 
 {-
 ************************************************************************
@@ -1663,15 +1987,15 @@ type LForeignDecl pass = Located (ForeignDecl pass)
 -- | Foreign Declaration
 data ForeignDecl pass
   = ForeignImport
-      { fd_name   :: Located (IdP pass)    -- defines this name
+      { fd_i_ext  :: XForeignImport pass   -- Post typechecker, rep_ty ~ sig_ty
+      , fd_name   :: Located (IdP pass)    -- defines this name
       , fd_sig_ty :: LHsSigType pass       -- sig_ty
-      , fd_co     :: PostTc pass Coercion  -- rep_ty ~ sig_ty
       , fd_fi     :: ForeignImport }
 
   | ForeignExport
-      { fd_name   :: Located (IdP pass)    -- uses this name
+      { fd_e_ext  :: XForeignExport pass   -- Post typechecker, rep_ty ~ sig_ty
+      , fd_name   :: Located (IdP pass)    -- uses this name
       , fd_sig_ty :: LHsSigType pass       -- sig_ty
-      , fd_co     :: PostTc pass Coercion  -- rep_ty ~ sig_ty
       , fd_fe     :: ForeignExport }
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',
@@ -1679,8 +2003,8 @@ data ForeignDecl pass
         --           'ApiAnnotation.AnnDcolon'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
+  | XForeignDecl (XXForeignDecl pass)
 
-deriving instance (DataId pass) => Data (ForeignDecl pass)
 {-
     In both ForeignImport and ForeignExport:
         sig_ty is the type given in the Haskell code
@@ -1690,11 +2014,15 @@ deriving instance (DataId pass) => Data (ForeignDecl pass)
     such as Int and IO that we know how to make foreign calls with.
 -}
 
-noForeignImportCoercionYet :: PlaceHolder
-noForeignImportCoercionYet = PlaceHolder
+type instance XForeignImport   GhcPs = NoExt
+type instance XForeignImport   GhcRn = NoExt
+type instance XForeignImport   GhcTc = Coercion
+
+type instance XForeignExport   GhcPs = NoExt
+type instance XForeignExport   GhcRn = NoExt
+type instance XForeignExport   GhcTc = Coercion
 
-noForeignExportCoercionYet :: PlaceHolder
-noForeignExportCoercionYet = PlaceHolder
+type instance XXForeignDecl    (GhcPass _) = NoExt
 
 -- Specification Of an imported external entity in dependence on the calling
 -- convention
@@ -1741,14 +2069,15 @@ data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
 -- pretty printing of foreign declarations
 --
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (ForeignDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (ForeignDecl p) where
   ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
     = hang (text "foreign import" <+> ppr fimport <+> ppr n)
          2 (dcolon <+> ppr ty)
   ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
     hang (text "foreign export" <+> ppr fexport <+> ppr n)
        2 (dcolon <+> ppr ty)
+  ppr (XForeignDecl x) = ppr x
 
 instance Outputable ForeignImport where
   ppr (CImport  cconv safety mHeader spec (L _ srcText)) =
@@ -1795,9 +2124,13 @@ type LRuleDecls pass = Located (RuleDecls pass)
 
   -- Note [Pragma source text] in BasicTypes
 -- | Rule Declarations
-data RuleDecls pass = HsRules { rds_src   :: SourceText
+data RuleDecls pass = HsRules { rds_ext   :: XCRuleDecls pass
+                              , rds_src   :: SourceText
                               , rds_rules :: [LRuleDecl pass] }
-deriving instance (DataId pass) => Data (RuleDecls pass)
+  | XRuleDecls (XXRuleDecls pass)
+
+type instance XCRuleDecls    (GhcPass _) = NoExt
+type instance XXRuleDecls    (GhcPass _) = NoExt
 
 -- | Located Rule Declaration
 type LRuleDecl pass = Located (RuleDecl pass)
@@ -1805,15 +2138,14 @@ type LRuleDecl pass = Located (RuleDecl pass)
 -- | Rule Declaration
 data RuleDecl pass
   = HsRule                             -- Source rule
+        (XHsRule pass)         -- After renamer, free-vars from the LHS and RHS
         (Located (SourceText,RuleName)) -- Rule name
                -- Note [Pragma source text] in BasicTypes
         Activation
         [LRuleBndr pass]        -- Forall'd vars; after typechecking this
                                 --   includes tyvars
         (Located (HsExpr pass)) -- LHS
-        (PostRn pass NameSet)   -- Free-vars from the LHS
         (Located (HsExpr pass)) -- RHS
-        (PostRn pass NameSet)   -- Free-vars from the RHS
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' :
         --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',
@@ -1823,7 +2155,16 @@ data RuleDecl pass
         --           'ApiAnnotation.AnnEqual',
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleDecl pass)
+  | XRuleDecl (XXRuleDecl pass)
+
+data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
+  deriving Data
+
+type instance XHsRule       GhcPs = NoExt
+type instance XHsRule       GhcRn = HsRuleRn
+type instance XHsRule       GhcTc = HsRuleRn
+
+type instance XXRuleDecl    (GhcPass _) = NoExt
 
 flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
 flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1833,157 +2174,46 @@ type LRuleBndr pass = Located (RuleBndr pass)
 
 -- | Rule Binder
 data RuleBndr pass
-  = RuleBndr (Located (IdP pass))
-  | RuleBndrSig (Located (IdP pass)) (LHsSigWcType pass)
+  = RuleBndr (XCRuleBndr pass)  (Located (IdP pass))
+  | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
+  | XRuleBndr (XXRuleBndr pass)
         -- ^
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleBndr pass)
+
+type instance XCRuleBndr    (GhcPass _) = NoExt
+type instance XRuleBndrSig  (GhcPass _) = NoExt
+type instance XXRuleBndr    (GhcPass _) = NoExt
 
 collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
 
 pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
 pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (RuleDecls pass) where
-  ppr (HsRules st rules)
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (RuleDecls p) where
+  ppr (HsRules _ st rules)
     = pprWithSourceText st (text "{-# RULES")
           <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
+  ppr (XRuleDecls x) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (RuleDecl pass) where
-  ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
+  ppr (HsRule _ name act ns lhs rhs)
         = sep [pprFullRuleName name <+> ppr act,
                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
                nest 6 (equals <+> pprExpr (unLoc rhs)) ]
         where
           pp_forall | null ns   = empty
                     | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
+  ppr (XRuleDecl x) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (RuleBndr pass) where
-   ppr (RuleBndr name) = ppr name
-   ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Vectorisation declarations}
-*                                                                      *
-************************************************************************
-
-A vectorisation pragma, one of
-
-  {-# VECTORISE f = closure1 g (scalar_map g) #-}
-  {-# VECTORISE SCALAR f #-}
-  {-# NOVECTORISE f #-}
-
-  {-# VECTORISE type T = ty #-}
-  {-# VECTORISE SCALAR type T #-}
--}
-
--- | Located Vectorise Declaration
-type LVectDecl pass = Located (VectDecl pass)
-
--- | Vectorise Declaration
-data VectDecl pass
-  = HsVect
-      SourceText   -- Note [Pragma source text] in BasicTypes
-      (Located (IdP pass))
-      (LHsExpr pass)
-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --           'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose'
-
-        -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsNoVect
-      SourceText   -- Note [Pragma source text] in BasicTypes
-      (Located (IdP pass))
-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --                                    'ApiAnnotation.AnnClose'
-
-        -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsVectTypeIn                -- pre type-checking
-      SourceText                -- Note [Pragma source text] in BasicTypes
-      Bool                      -- 'TRUE' => SCALAR declaration
-      (Located (IdP pass))
-      (Maybe (Located (IdP pass))) -- 'Nothing' => no right-hand side
-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --           'ApiAnnotation.AnnType','ApiAnnotation.AnnClose',
-        --           'ApiAnnotation.AnnEqual'
-
-        -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsVectTypeOut               -- post type-checking
-      Bool                      -- 'TRUE' => SCALAR declaration
-      TyCon
-      (Maybe TyCon)             -- 'Nothing' => no right-hand side
-  | HsVectClassIn               -- pre type-checking
-      SourceText                -- Note [Pragma source text] in BasicTypes
-      (Located (IdP pass))
-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-        --           'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose',
-
-       -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsVectClassOut              -- post type-checking
-      Class
-  | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
-      (LHsSigType pass)
-  | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
-      ClsInst
-deriving instance (DataId pass) => Data (VectDecl pass)
-
-lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
-lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name
-lvectDeclName (L _ (HsNoVect _     (L _ name)))      = getName name
-lvectDeclName (L _ (HsVectTypeIn _  _ (L _ name) _)) = getName name
-lvectDeclName (L _ (HsVectTypeOut  _ tycon _))       = getName tycon
-lvectDeclName (L _ (HsVectClassIn _ (L _ name)))     = getName name
-lvectDeclName (L _ (HsVectClassOut cls))             = getName cls
-lvectDeclName (L _ (HsVectInstIn _))
-  = panic "HsDecls.lvectDeclName: HsVectInstIn"
-lvectDeclName (L _ (HsVectInstOut  _))
-  = panic "HsDecls.lvectDeclName: HsVectInstOut"
-
-lvectInstDecl :: LVectDecl pass -> Bool
-lvectInstDecl (L _ (HsVectInstIn _))  = True
-lvectInstDecl (L _ (HsVectInstOut _)) = True
-lvectInstDecl _                       = False
-
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (VectDecl pass) where
-  ppr (HsVect _ v rhs)
-    = sep [text "{-# VECTORISE" <+> ppr v,
-           nest 4 $
-             pprExpr (unLoc rhs) <+> text "#-}" ]
-  ppr (HsNoVect _ v)
-    = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
-  ppr (HsVectTypeIn _ False t Nothing)
-    = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn _ False t (Just t'))
-    = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectTypeIn _ True t Nothing)
-    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeIn _ True t (Just t'))
-    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectTypeOut False t Nothing)
-    = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeOut False t (Just t'))
-    = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectTypeOut True t Nothing)
-    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
-  ppr (HsVectTypeOut True t (Just t'))
-    = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
-  ppr (HsVectClassIn _ c)
-    = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
-  ppr (HsVectClassOut c)
-    = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
-  ppr (HsVectInstIn ty)
-    = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
-  ppr (HsVectInstOut i)
-    = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
+   ppr (RuleBndr _ name) = ppr name
+   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
+   ppr (XRuleBndr x) = ppr x
 
 {-
 ************************************************************************
@@ -2029,27 +2259,39 @@ type LWarnDecls pass = Located (WarnDecls pass)
 
  -- Note [Pragma source text] in BasicTypes
 -- | Warning pragma Declarations
-data WarnDecls pass = Warnings { wd_src :: SourceText
+data WarnDecls pass = Warnings { wd_ext      :: XWarnings pass
+                               , wd_src      :: SourceText
                                , wd_warnings :: [LWarnDecl pass]
                                }
-deriving instance (DataId pass) => Data (WarnDecls pass)
+  | XWarnDecls (XXWarnDecls pass)
+
+type instance XWarnings      (GhcPass _) = NoExt
+type instance XXWarnDecls    (GhcPass _) = NoExt
 
 -- | Located Warning pragma Declaration
 type LWarnDecl pass = Located (WarnDecl pass)
 
 -- | Warning pragma Declaration
-data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt
-deriving instance (DataId pass) => Data (WarnDecl pass)
+data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt
+                   | XWarnDecl (XXWarnDecl pass)
+
+type instance XWarning      (GhcPass _) = NoExt
+type instance XXWarnDecl    (GhcPass _) = NoExt
 
-instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where
-    ppr (Warnings (SourceText src) decls)
+
+instance (p ~ GhcPass pass,OutputableBndr (IdP p))
+        => Outputable (WarnDecls p) where
+    ppr (Warnings _ (SourceText src) decls)
       = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
-    ppr (Warnings NoSourceText _decls) = panic "WarnDecls"
+    ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
+    ppr (XWarnDecls x) = ppr x
 
-instance OutputableBndr (IdP pass) => Outputable (WarnDecl pass) where
-    ppr (Warning thing txt)
+instance (p ~ GhcPass pass, OutputableBndr (IdP p))
+       => Outputable (WarnDecl p) where
+    ppr (Warning _ thing txt)
       = hsep ( punctuate comma (map ppr thing))
               <+> ppr txt
+    ppr (XWarnDecl x) = ppr x
 
 {-
 ************************************************************************
@@ -2064,6 +2306,7 @@ type LAnnDecl pass = Located (AnnDecl pass)
 
 -- | Annotation Declaration
 data AnnDecl pass = HsAnnotation
+                      (XHsAnnotation pass)
                       SourceText -- Note [Pragma source text] in BasicTypes
                       (AnnProvenance (IdP pass)) (Located (HsExpr pass))
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -2072,12 +2315,15 @@ data AnnDecl pass = HsAnnotation
       --           'ApiAnnotation.AnnClose'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (AnnDecl pass)
+  | XAnnDecl (XXAnnDecl pass)
+
+type instance XHsAnnotation (GhcPass _) = NoExt
+type instance XXAnnDecl     (GhcPass _) = NoExt
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (AnnDecl pass) where
-    ppr (HsAnnotation _ provenance expr)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
+    ppr (HsAnnotation _ _ provenance expr)
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
+    ppr (XAnnDecl x) = ppr x
 
 -- | Annotation Provenance
 data AnnProvenance name = ValueAnnProvenance (Located name)
@@ -2115,21 +2361,28 @@ type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)
 -- top-level declarations
 -- | Role Annotation Declaration
 data RoleAnnotDecl pass
-  = RoleAnnotDecl (Located (IdP pass))   -- type constructor
+  = RoleAnnotDecl (XCRoleAnnotDecl pass)
+                  (Located (IdP pass))   -- type constructor
                   [Located (Maybe Role)] -- optional annotations
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
       --           'ApiAnnotation.AnnRole'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RoleAnnotDecl pass)
+  | XRoleAnnotDecl (XXRoleAnnotDecl pass)
+
+type instance XCRoleAnnotDecl (GhcPass _) = NoExt
+type instance XXRoleAnnotDecl (GhcPass _) = NoExt
 
-instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where
-  ppr (RoleAnnotDecl ltycon roles)
-    = text "type role" <+> ppr ltycon <+>
+instance (p ~ GhcPass pass, OutputableBndr (IdP p))
+       => Outputable (RoleAnnotDecl p) where
+  ppr (RoleAnnotDecl _ ltycon roles)
+    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>
       hsep (map (pp_role . unLoc) roles)
     where
       pp_role Nothing  = underscore
       pp_role (Just r) = ppr r
+  ppr (XRoleAnnotDecl x) = ppr x
 
 roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass)
-roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
+roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name
+roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName"
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
index d9c5dba296..affbf1bac0 100644
--- a/compiler/hsSyn/HsDoc.hs
+++ b/compiler/hsSyn/HsDoc.hs
@@ -1,30 +1,152 @@
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module HsDoc (
-  HsDocString(..),
-  LHsDocString,
-  ppr_mbDoc
+module HsDoc
+  ( HsDocString
+  , LHsDocString
+  , mkHsDocString
+  , mkHsDocStringUtf8ByteString
+  , unpackHDS
+  , hsDocStringToByteString
+  , ppr_mbDoc
+
+  , appendDocs
+  , concatDocs
+
+  , DeclDocMap(..)
+  , emptyDeclDocMap
+
+  , ArgDocMap(..)
+  , emptyArgDocMap
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
+import Binary
+import Encoding
+import FastFunctions
+import Name
 import Outputable
 import SrcLoc
-import FastString
 
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Internal as BS
 import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Foreign
 
 -- | Haskell Documentation String
-newtype HsDocString = HsDocString FastString
+--
+-- Internally this is a UTF8-Encoded 'ByteString'.
+newtype HsDocString = HsDocString ByteString
+  -- There are at least two plausible Semigroup instances for this type:
+  --
+  -- 1. Simple string concatenation.
+  -- 2. Concatenation as documentation paragraphs with newlines in between.
+  --
+  -- To avoid confusion, we pass on defining an instance at all.
   deriving (Eq, Show, Data)
 
 -- | Located Haskell Documentation String
 type LHsDocString = Located HsDocString
 
+instance Binary HsDocString where
+  put_ bh (HsDocString bs) = put_ bh bs
+  get bh = HsDocString <$> get bh
+
 instance Outputable HsDocString where
-  ppr (HsDocString fs) = ftext fs
+  ppr = doubleQuotes . text . unpackHDS
+
+mkHsDocString :: String -> HsDocString
+mkHsDocString s =
+  inlinePerformIO $ do
+    let len = utf8EncodedLength s
+    buf <- mallocForeignPtrBytes len
+    withForeignPtr buf $ \ptr -> do
+      utf8EncodeString ptr s
+      pure (HsDocString (BS.fromForeignPtr buf 0 len))
+
+-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.
+mkHsDocStringUtf8ByteString :: ByteString -> HsDocString
+mkHsDocStringUtf8ByteString = HsDocString
+
+unpackHDS :: HsDocString -> String
+unpackHDS = utf8DecodeByteString . hsDocStringToByteString
+
+-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.
+hsDocStringToByteString :: HsDocString -> ByteString
+hsDocStringToByteString (HsDocString bs) = bs
 
 ppr_mbDoc :: Maybe LHsDocString -> SDoc
 ppr_mbDoc (Just doc) = ppr doc
 ppr_mbDoc Nothing    = empty
 
+-- | Join two docstrings.
+--
+-- Non-empty docstrings are joined with two newlines in between,
+-- resulting in separate paragraphs.
+appendDocs :: HsDocString -> HsDocString -> HsDocString
+appendDocs x y =
+  fromMaybe
+    (HsDocString BS.empty)
+    (concatDocs [x, y])
+
+-- | Concat docstrings with two newlines in between.
+--
+-- Empty docstrings are skipped.
+--
+-- If all inputs are empty, 'Nothing' is returned.
+concatDocs :: [HsDocString] -> Maybe HsDocString
+concatDocs xs =
+    if BS.null b
+      then Nothing
+      else Just (HsDocString b)
+  where
+    b = BS.intercalate (C8.pack "\n\n")
+      . filter (not . BS.null)
+      . map hsDocStringToByteString
+      $ xs
+
+-- | Docs for declarations: functions, data types, instances, methods etc.
+newtype DeclDocMap = DeclDocMap (Map Name HsDocString)
+
+instance Binary DeclDocMap where
+  put_ bh (DeclDocMap m) = put_ bh (Map.toList m)
+  -- We can't rely on a deterministic ordering of the `Name`s here.
+  -- See the comments on `Name`'s `Ord` instance for context.
+  get bh = DeclDocMap . Map.fromList <$> get bh
+
+instance Outputable DeclDocMap where
+  ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m))
+    where
+      pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyDeclDocMap :: DeclDocMap
+emptyDeclDocMap = DeclDocMap Map.empty
+
+-- | Docs for arguments. E.g. function arguments, method arguments.
+newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))
+
+instance Binary ArgDocMap where
+  put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m))
+  -- We can't rely on a deterministic ordering of the `Name`s here.
+  -- See the comments on `Name`'s `Ord` instance for context.
+  get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh
+
+instance Outputable ArgDocMap where
+  ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))
+    where
+      pprPair (name, int_map) =
+        ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)
+      pprIntMap im = vcat (map pprIPair (Map.toAscList im))
+      pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)
+
+emptyArgDocMap :: ArgDocMap
+emptyArgDocMap = ArgDocMap Map.empty
diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs
index e2244312d0..1a1c259c01 100644
--- a/compiler/hsSyn/HsDumpAst.hs
+++ b/compiler/hsSyn/HsDumpAst.hs
@@ -15,8 +15,9 @@ module HsDumpAst (
         BlankSrcSpan(..),
     ) where
 
+import GhcPrelude
+
 import Data.Data hiding (Fixity)
-import Data.List
 import Bag
 import BasicTypes
 import FastString
@@ -28,8 +29,7 @@ import HsSyn
 import OccName hiding (occName)
 import Var
 import Module
-import DynFlags
-import Outputable hiding (space)
+import Outputable
 
 import qualified Data.ByteString as B
 
@@ -39,11 +39,11 @@ data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
 -- | Show a GHC syntax tree. This parameterised because it is also used for
 -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
 -- out, to avoid comparing locations, only structure
-showAstData :: Data a => BlankSrcSpan -> a -> String
-showAstData b = showAstData' 0
+showAstData :: Data a => BlankSrcSpan -> a -> SDoc
+showAstData b a0 = blankLine $$ showAstData' a0
   where
-    showAstData' :: Data a => Int -> a -> String
-    showAstData' n =
+    showAstData' :: Data a => a -> SDoc
+    showAstData' =
       generic
               `ext1Q` list
               `extQ` string `extQ` fastString `extQ` srcSpan
@@ -54,118 +54,118 @@ showAstData b = showAstData' 0
               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
               `extQ` fixity
               `ext2Q` located
-      where generic :: Data a => a -> String
-            generic t = indent n ++ "(" ++ showConstr (toConstr t)
-                     ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")"
-
-            space "" = ""
-            space s  = ' ':s
 
-            indent i = "\n" ++ replicate i ' '
+      where generic :: Data a => a -> SDoc
+            generic t = parens $ text (showConstr (toConstr t))
+                                  $$ vcat (gmapQ showAstData' t)
 
-            string :: String -> String
-            string     = normalize_newlines . show
+            string :: String -> SDoc
+            string     = text . normalize_newlines . show
 
-            fastString :: FastString -> String
-            fastString = ("{FastString: "++) . (++"}") . normalize_newlines
-                       . show
+            fastString :: FastString -> SDoc
+            fastString s = braces $
+                            text "FastString: "
+                         <> text (normalize_newlines . show $ s)
 
-            bytestring :: B.ByteString -> String
-            bytestring = normalize_newlines . show
+            bytestring :: B.ByteString -> SDoc
+            bytestring = text . normalize_newlines . show
 
-            list l     = indent n ++ "["
-                                ++ intercalate "," (map (showAstData' (n+1)) l)
-                                ++ "]"
+            list []    = brackets empty
+            list [x]   = brackets (showAstData' x)
+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)
+                                $$ go x2 xs
+              where
+                go y [] = text "," <> showAstData' y <> text "]"
+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
 
             -- Eliminate word-size dependence
-            lit :: HsLit GhcPs -> String
+            lit :: HsLit GhcPs -> SDoc
             lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
             lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
             lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
             lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
             lit l                  = generic l
 
-            litr :: HsLit GhcRn -> String
+            litr :: HsLit GhcRn -> SDoc
             litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
             litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
             litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
             litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
             litr l                  = generic l
 
-            litt :: HsLit GhcTc -> String
+            litt :: HsLit GhcTc -> SDoc
             litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
             litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
             litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
             litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
             litt l                  = generic l
 
-            numericLit :: String -> Integer -> SourceText -> String
-            numericLit tag x s = indent n ++ unwords [ "{" ++ tag
-                                                     , generic x
-                                                     , generic s ++ "}" ]
+            numericLit :: String -> Integer -> SourceText -> SDoc
+            numericLit tag x s = braces $ hsep [ text tag
+                                               , generic x
+                                               , generic s ]
 
-            name :: Name -> String
-            name       = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
+            name :: Name -> SDoc
+            name nm    = braces $ text "Name: " <> ppr nm
 
-            occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString
+            occName n  =  braces $
+                          text "OccName: "
+                       <> text (OccName.occNameString n)
 
-            moduleName :: ModuleName -> String
-            moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
+            moduleName :: ModuleName -> SDoc
+            moduleName m = braces $ text "ModuleName: " <> ppr m
 
-            srcSpan :: SrcSpan -> String
+            srcSpan :: SrcSpan -> SDoc
             srcSpan ss = case b of
-             BlankSrcSpan -> "{ "++ "ss" ++"}"
-             NoBlankSrcSpan ->
-                             "{ "++ showSDoc_ (hang (ppr ss) (n+2)
-                                              -- TODO: show annotations here
-                                                    (text "")
-                                              )
-                          ++"}"
-
-            var  :: Var -> String
-            var        = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
-
-            dataCon :: DataCon -> String
-            dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
-
-            bagRdrName:: Bag (Located (HsBind GhcPs)) -> String
-            bagRdrName = ("{Bag(Located (HsBind GhcPs)): "++) . (++"}")
-                          . list . bagToList
-
-            bagName   :: Bag (Located (HsBind GhcRn)) -> String
-            bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}")
-                           . list . bagToList
-
-            bagVar    :: Bag (Located (HsBind GhcTc)) -> String
-            bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}")
-                           . list . bagToList
-
-            nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
-
-            fixity :: Fixity -> String
-            fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
-
-            located :: (Data b,Data loc) => GenLocated loc b -> String
-            located (L ss a) =
-              indent n ++ "("
-                ++ case cast ss of
+             BlankSrcSpan -> text "{ ss }"
+             NoBlankSrcSpan -> braces $ char ' ' <>
+                             (hang (ppr ss) 1
+                                   -- TODO: show annotations here
+                                   (text ""))
+
+            var  :: Var -> SDoc
+            var v      = braces $ text "Var: " <> ppr v
+
+            dataCon :: DataCon -> SDoc
+            dataCon c  = braces $ text "DataCon: " <> ppr c
+
+            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc
+            bagRdrName bg =  braces $
+                             text "Bag(Located (HsBind GhcPs)):"
+                          $$ (list . bagToList $ bg)
+
+            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc
+            bagName bg  =  braces $
+                           text "Bag(Located (HsBind Name)):"
+                        $$ (list . bagToList $ bg)
+
+            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc
+            bagVar bg  =  braces $
+                          text "Bag(Located (HsBind Var)):"
+                       $$ (list . bagToList $ bg)
+
+            nameSet ns =  braces $
+                          text "NameSet:"
+                       $$ (list . nameSetElemsStable $ ns)
+
+            fixity :: Fixity -> SDoc
+            fixity fx =  braces $
+                         text "Fixity: "
+                      <> ppr fx
+
+            located :: (Data b,Data loc) => GenLocated loc b -> SDoc
+            located (L ss a) = parens $
+                   case cast ss of
                         Just (s :: SrcSpan) ->
                           srcSpan s
-                        Nothing -> "nnnnnnnn"
-                      ++ showAstData' (n+1) a
-                      ++ ")"
+                        Nothing -> text "nnnnnnnn"
+                      $$ showAstData' a
 
 normalize_newlines :: String -> String
 normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
 normalize_newlines (x:xs)                 = x:normalize_newlines xs
 normalize_newlines []                     = []
 
-showSDoc_ :: SDoc -> String
-showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
-
-showSDocDebug_ :: SDoc -> String
-showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 016b02fe2f..45b1b07d73 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Abstract Haskell syntax for expressions.
 module HsExpr where
@@ -18,6 +19,8 @@ module HsExpr where
 #include "HsVersions.h"
 
 -- friends:
+import GhcPrelude
+
 import HsDecls
 import HsPat
 import HsLit
@@ -79,12 +82,6 @@ type PostTcExpr  = HsExpr GhcTc
 -- than is convenient to keep individually.
 type PostTcTable = [(Name, PostTcExpr)]
 
-noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr"))
-
-noPostTcTable :: PostTcTable
-noPostTcTable = []
-
 -------------------------
 -- | Syntax Expression
 --
@@ -101,23 +98,22 @@ noPostTcTable = []
 -- >                         (syn_arg_wraps[1] arg1) ...
 --
 -- where the actual arguments come from elsewhere in the AST.
--- This could be defined using @PostRn@ and @PostTc@ and such, but it's
+-- This could be defined using @GhcPass p@ and such, but it's
 -- harder to get it all to work out that way. ('noSyntaxExpr' is hard to
 -- write, for example.)
 data SyntaxExpr p = SyntaxExpr { syn_expr      :: HsExpr p
                                , syn_arg_wraps :: [HsWrapper]
                                , syn_res_wrap  :: HsWrapper }
-deriving instance (DataId p) => Data (SyntaxExpr p)
 
 -- | This is used for rebindable-syntax pieces that are too polymorphic
 -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
-noExpr :: SourceTextX p => HsExpr p
-noExpr = HsLit (HsString (sourceText  "noExpr") (fsLit "noExpr"))
+noExpr :: HsExpr (GhcPass p)
+noExpr = HsLit noExt (HsString (SourceText  "noExpr") (fsLit "noExpr"))
 
-noSyntaxExpr :: SourceTextX p => SyntaxExpr p
+noSyntaxExpr :: SyntaxExpr (GhcPass p)
                               -- Before renaming, and sometimes after,
                               -- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString noSourceText
+noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit noExt (HsString NoSourceText
                                                         (fsLit "noSyntaxExpr"))
                           , syn_arg_wraps = []
                           , syn_res_wrap  = WpHole }
@@ -125,13 +121,14 @@ noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString noSourceText
 -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
 -- renamer), missing its HsWrappers.
 mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar noExt $ noLoc name
                                  , syn_arg_wraps = []
                                  , syn_res_wrap  = WpHole }
   -- don't care about filling in syn_arg_wraps because we're clearly
   -- not past the typechecker
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (SyntaxExpr p) where
   ppr (SyntaxExpr { syn_expr      = expr
                   , syn_arg_wraps = arg_wraps
                   , syn_res_wrap  = res_wrap })
@@ -182,8 +179,15 @@ is Less Cool because
     typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
 -}
 
--- | An unbound variable; used for treating out-of-scope variables as
--- expression holes
+-- | An unbound variable; used for treating
+-- out-of-scope variables as expression holes
+--
+-- Either "x", "y"     Plain OutOfScope
+-- or     "_", "_x"    A TrueExprHole
+--
+-- Both forms indicate an out-of-scope variable,  but the latter
+-- indicates that the user /expects/ it to be out of scope, and
+-- just wants GHC to report its type
 data UnboundVar
   = OutOfScope OccName GlobalRdrEnv  -- ^ An (unqualified) out-of-scope
                                      -- variable, together with the GlobalRdrEnv
@@ -196,7 +200,8 @@ data UnboundVar
   deriving Data
 
 instance Outputable UnboundVar where
-    ppr = ppr . unboundVarOcc
+    ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ)
+    ppr (TrueExprHole occ) = text "ExprHole"   <> parens (ppr occ)
 
 unboundVarOcc :: UnboundVar -> OccName
 unboundVarOcc (OutOfScope occ _) = occ
@@ -274,11 +279,13 @@ information to use is the GlobalRdrEnv itself.
 
 -- | A Haskell expression.
 data HsExpr p
-  = HsVar     (Located (IdP p)) -- ^ Variable
+  = HsVar     (XVar p)
+              (Located (IdP p)) -- ^ Variable
 
                              -- See Note [Located RdrNames]
 
-  | HsUnboundVar UnboundVar  -- ^ Unbound variable; also used for "holes"
+  | HsUnboundVar (XUnboundVar p)
+                 UnboundVar  -- ^ Unbound variable; also used for "holes"
                              --   (_ or _x).
                              -- Turned from HsVar to HsUnboundVar by the
                              --   renamer, when it finds an out-of-scope
@@ -286,24 +293,31 @@ data HsExpr p
                              -- Turned into HsVar by type checker, to support
                              --   deferred type errors.
 
-  | HsConLikeOut ConLike     -- ^ After typechecker only; must be different
+  | HsConLikeOut (XConLikeOut p)
+                 ConLike     -- ^ After typechecker only; must be different
                              -- HsVar for pretty printing
 
-  | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
+  | HsRecFld  (XRecFld p)
+              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
                                     -- Not in use after typechecking
 
-  | HsOverLabel (Maybe (IdP p)) FastString
+  | HsOverLabel (XOverLabel p)
+                (Maybe (IdP p)) FastString
      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
      --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
      --   in-scope 'fromLabel'.
      --   NB: Not in use after typechecking
 
-  | HsIPVar   HsIPName       -- ^ Implicit parameter (not in use after typechecking)
-  | HsOverLit (HsOverLit p)  -- ^ Overloaded literals
+  | HsIPVar   (XIPVar p)
+              HsIPName   -- ^ Implicit parameter (not in use after typechecking)
+  | HsOverLit (XOverLitE p)
+              (HsOverLit p)  -- ^ Overloaded literals
 
-  | HsLit     (HsLit p)      -- ^ Simple (non-overloaded) literals
+  | HsLit     (XLitE p)
+              (HsLit p)      -- ^ Simple (non-overloaded) literals
 
-  | HsLam     (MatchGroup p (LHsExpr p))
+  | HsLam     (XLam p)
+              (MatchGroup p (LHsExpr p))
                        -- ^ Lambda abstraction. Currently always a single match
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
@@ -311,7 +325,7 @@ data HsExpr p
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
+  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
@@ -319,28 +333,24 @@ data HsExpr p
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsApp     (LHsExpr p) (LHsExpr p) -- ^ Application
+  | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
 
-  | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application
+  | HsAppType (XAppTypeE p) (LHsExpr p)  -- ^ Visible type application
        --
        -- Explicit type argument; e.g  f @Int x y
        -- NB: Has wildcards, but no implicit quantification
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
 
-  -- TODO:AZ: Sort out Name
-  | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing
-
-
   -- | Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 
   -- NB We need an expr for the operator in an OpApp/Section since
   -- the typechecker may need to apply the operator to a few types.
 
-  | OpApp       (LHsExpr p)       -- left operand
+  | OpApp       (XOpApp p)
+                (LHsExpr p)       -- left operand
                 (LHsExpr p)       -- operator
-                (PostRn p Fixity) -- Renamer adds fixity; bottom until then
                 (LHsExpr p)       -- right operand
 
   -- | Negation operator. Contains the negated expression and the name
@@ -349,18 +359,22 @@ data HsExpr p
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | NegApp      (LHsExpr p)
+  | NegApp      (XNegApp p)
+                (LHsExpr p)
                 (SyntaxExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
   --             'ApiAnnotation.AnnClose' @')'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsPar       (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]
+  | HsPar       (XPar p)
+                (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]
 
-  | SectionL    (LHsExpr p)    -- operand; see Note [Sections in HsSyn]
+  | SectionL    (XSectionL p)
+                (LHsExpr p)    -- operand; see Note [Sections in HsSyn]
                 (LHsExpr p)    -- operator
-  | SectionR    (LHsExpr p)    -- operator; see Note [Sections in HsSyn]
+  | SectionR    (XSectionR p)
+                (LHsExpr p)    -- operator; see Note [Sections in HsSyn]
                 (LHsExpr p)    -- operand
 
   -- | Used for explicit tuples and sections thereof
@@ -370,6 +384,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitTuple
+        (XExplicitTuple p)
         [LHsTupArg p]
         Boxity
 
@@ -381,17 +396,18 @@ data HsExpr p
   --  There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
   --  the expression, (arity - alternative) after it
   | ExplicitSum
+          (XExplicitSum p)
           ConTag --  Alternative (one-based)
           Arity  --  Sum arity
           (LHsExpr p)
-          (PostTc p [Type])   -- the type arguments
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
   --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
   --       'ApiAnnotation.AnnClose' @'}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCase      (LHsExpr p)
+  | HsCase      (XCase p)
+                (LHsExpr p)
                 (MatchGroup p (LHsExpr p))
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
@@ -400,7 +416,8 @@ data HsExpr p
   --       'ApiAnnotation.AnnElse',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsIf        (Maybe (SyntaxExpr p)) -- cond function
+  | HsIf        (XIf p)
+                (Maybe (SyntaxExpr p)) -- cond function
                                         -- Nothing => use the built-in 'if'
                                         -- See Note [Rebindable if]
                 (LHsExpr p)    --  predicate
@@ -413,7 +430,7 @@ data HsExpr p
   --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsMultiIf   (PostTc p Type) [LGRHS p (LHsExpr p)]
+  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]
 
   -- | let(rec)
   --
@@ -422,7 +439,8 @@ data HsExpr p
   --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsLet       (LHsLocalBinds p)
+  | HsLet       (XLet p)
+                (LHsLocalBinds p)
                 (LHsExpr  p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
@@ -431,11 +449,11 @@ data HsExpr p
   --             'ApiAnnotation.AnnClose'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsDo        (HsStmtContext Name)     -- The parameterisation is unimportant
+  | HsDo        (XDo p)                  -- Type of the whole expression
+                (HsStmtContext Name)     -- The parameterisation is unimportant
                                          -- because in this context we never use
                                          -- the PatGuard or ParStmt variant
                 (Located [ExprLStmt p]) -- "do":one or more stmts
-                (PostTc p Type)         -- Type of the whole expression
 
   -- | Syntactic list: [a,b,c,...]
   --
@@ -444,23 +462,11 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitList
-                (PostTc p Type)        -- Gives type of components of list
+                (XExplicitList p)  -- Gives type of components of list
                 (Maybe (SyntaxExpr p))
                                    -- For OverloadedLists, the fromListN witness
                 [LHsExpr p]
 
-  -- | Syntactic parallel array: [:e1, ..., en:]
-  --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-  --              'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnComma',
-  --              'ApiAnnotation.AnnVbar'
-  --              'ApiAnnotation.AnnClose' @':]'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | ExplicitPArr
-                (PostTc p Type)   -- type of elements of the parallel array
-                [LHsExpr p]
-
   -- | Record construction
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
@@ -468,11 +474,9 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordCon
-      { rcon_con_name :: Located (IdP p)    -- The constructor name;
+      { rcon_ext      :: XRecordCon p
+      , rcon_con_name :: Located (IdP p)    -- The constructor name;
                                             --  not used after type checking
-      , rcon_con_like :: PostTc p ConLike
-                                      -- The data constructor or pattern synonym
-      , rcon_con_expr :: PostTcExpr         -- Instantiated constructor function
       , rcon_flds     :: HsRecordBinds p }  -- The fields
 
   -- | Record update
@@ -482,18 +486,9 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordUpd
-      { rupd_expr :: LHsExpr p
+      { rupd_ext  :: XRecordUpd p
+      , rupd_expr :: LHsExpr p
       , rupd_flds :: [LHsRecUpdField p]
-      , rupd_cons :: PostTc p [ConLike]
-                -- Filled in by the type checker to the
-                -- _non-empty_ list of DataCons that have
-                -- all the upd'd fields
-
-      , rupd_in_tys  :: PostTc p [Type] -- Argument types of *input* record type
-      , rupd_out_tys :: PostTc p [Type] --             and  *output* record type
-                                       -- The original type can be reconstructed
-                                       -- with conLikeResTy
-      , rupd_wrap :: PostTc p HsWrapper  -- See note [Record Update HsWrapper]
       }
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
@@ -504,14 +499,10 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExprWithTySig
-                (LHsExpr p)
-                (LHsSigWcType p)
-
-  | ExprWithTySigOut              -- Post typechecking
-                (LHsExpr p)
-                (LHsSigWcType GhcRn)  -- Retain the signature,
+                (XExprWithTySig p)   -- Retain the signature,
                                      -- as HsSigType Name, for
                                      -- round-tripping purposes
+                (LHsExpr p)
 
   -- | Arithmetic sequence
   --
@@ -521,31 +512,14 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ArithSeq
-                PostTcExpr
+                (XArithSeq p)
                 (Maybe (SyntaxExpr p))
                                   -- For OverloadedLists, the fromList witness
                 (ArithSeqInfo p)
 
-  -- | Arithmetic sequence for parallel array
-  --
-  -- > [:e1..e2:] or [:e1, e2..e3:]
-  --
-  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',
-  --              'ApiAnnotation.AnnVbar',
-  --              'ApiAnnotation.AnnClose' @':]'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | PArrSeq
-                PostTcExpr
-                (ArithSeqInfo p)
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
-  --             'ApiAnnotation.AnnVal' or 'ApiAnnotation.AnnValStr',
-  --              'ApiAnnotation.AnnClose' @'\#-}'@
-
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
+  | HsSCC       (XSCC p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
                 StringLiteral         -- "set cost centre" SCC pragma
                 (LHsExpr p)           -- expr whose cost is to be measured
 
@@ -553,7 +527,8 @@ data HsExpr p
   --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes
+  | HsCoreAnn   (XCoreAnn p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
                 StringLiteral         -- hdaume: core annotation
                 (LHsExpr p)
 
@@ -565,15 +540,17 @@ data HsExpr p
   --         'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsBracket    (HsBracket p)
+  | HsBracket    (XBracket p) (HsBracket p)
 
     -- See Note [Pending Splices]
   | HsRnBracketOut
+      (XRnBracketOut p)
       (HsBracket GhcRn)    -- Output of the renamer is the *original* renamed
                            -- expression, plus
       [PendingRnSplice]    -- _renamed_ splices to be type checked
 
   | HsTcBracketOut
+      (XTcBracketOut p)
       (HsBracket GhcRn)    -- Output of the type checker is the *original*
                            -- renamed expression, plus
       [PendingTcSplice]    -- _typechecked_ splices to be
@@ -583,7 +560,7 @@ data HsExpr p
   --         'ApiAnnotation.AnnClose'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSpliceE  (HsSplice p)
+  | HsSpliceE  (XSpliceE p) (HsSplice p)
 
   -----------------------------------------------------------
   -- Arrow notation extension
@@ -594,7 +571,8 @@ data HsExpr p
   --          'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsProc      (LPat p)               -- arrow abstraction, proc
+  | HsProc      (XProc p)
+                (LPat p)               -- arrow abstraction, proc
                 (LHsCmdTop p)          -- body of the abstraction
                                        -- always has an empty stack
 
@@ -603,7 +581,7 @@ data HsExpr p
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsStatic (PostRn p NameSet) -- Free variables of the body
+  | HsStatic (XStatic p) -- Free variables of the body
              (LHsExpr p)        -- Body
 
   ---------------------------------------
@@ -617,10 +595,10 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrApp             -- Arrow tail, or arrow application (f -< arg)
+        (XArrApp p)     -- type of the arrow expressions f,
+                        -- of the form a t t', where arg :: t
         (LHsExpr p)     -- arrow expression, f
         (LHsExpr p)     -- input expression, arg
-        (PostTc p Type) -- type of the arrow expressions f,
-                        -- of the form a t t', where arg :: t
         HsArrAppType    -- higher-order (-<<) or first-order (-<)
         Bool            -- True => right-to-left (f -< arg)
                         -- False => left-to-right (arg >- f)
@@ -630,6 +608,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
+        (XArrForm p)
         (LHsExpr p)      -- the operator
                          -- after type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
@@ -641,10 +620,12 @@ data HsExpr p
   -- Haskell program coverage (Hpc) Support
 
   | HsTick
+     (XTick p)
      (Tickish (IdP p))
      (LHsExpr p)                       -- sub-expression
 
   | HsBinTick
+     (XBinTick p)
      Int                                -- module-local tick number for True
      Int                                -- module-local tick number for False
      (LHsExpr p)                        -- sub-expression
@@ -660,6 +641,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsTickPragma                      -- A pragma introduced tick
+     (XTickPragma p)
      SourceText                       -- Note [Pragma source text] in BasicTypes
      (StringLiteral,(Int,Int),(Int,Int))
                                       -- external span for this tick
@@ -672,24 +654,26 @@ data HsExpr p
   -- These constructors only appear temporarily in the parser.
   -- The renamer translates them into the Right Thing.
 
-  | EWildPat                 -- wildcard
+  | EWildPat (XEWildPat p)        -- wildcard
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | EAsPat      (Located (IdP p)) -- as pattern
+  | EAsPat      (XEAsPat p)
+                (Located (IdP p)) -- as pattern
                 (LHsExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | EViewPat    (LHsExpr p) -- view pattern
+  | EViewPat    (XEViewPat p)
+                (LHsExpr p) -- view pattern
                 (LHsExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | ELazyPat    (LHsExpr p) -- ~ pattern
+  | ELazyPat    (XELazyPat p) (LHsExpr p) -- ~ pattern
 
 
   ---------------------------------------
@@ -698,10 +682,128 @@ data HsExpr p
   -- See Note [Detecting forced eta expansion] in DsExpr. This invariant
   -- is maintained by HsUtils.mkHsWrap.
 
-  |  HsWrap     HsWrapper    -- TRANSLATION
+  |  HsWrap     (XWrap p)
+                HsWrapper    -- TRANSLATION
                 (HsExpr p)
 
-deriving instance (DataId p) => Data (HsExpr p)
+  | XExpr       (XXExpr p) -- Note [Trees that Grow] extension constructor
+
+
+-- | Extra data fields for a 'RecordCon', added by the type checker
+data RecordConTc = RecordConTc
+      { rcon_con_like :: ConLike      -- The data constructor or pattern synonym
+      , rcon_con_expr :: PostTcExpr   -- Instantiated constructor function
+      }
+
+-- | Extra data fields for a 'RecordUpd', added by the type checker
+data RecordUpdTc = RecordUpdTc
+      { rupd_cons :: [ConLike]
+                -- Filled in by the type checker to the
+                -- _non-empty_ list of DataCons that have
+                -- all the upd'd fields
+
+      , rupd_in_tys  :: [Type] -- Argument types of *input* record type
+      , rupd_out_tys :: [Type] --             and  *output* record type
+                               -- The original type can be reconstructed
+                               -- with conLikeResTy
+      , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
+      } deriving Data
+
+-- ---------------------------------------------------------------------
+
+type instance XVar           (GhcPass _) = NoExt
+type instance XUnboundVar    (GhcPass _) = NoExt
+type instance XConLikeOut    (GhcPass _) = NoExt
+type instance XRecFld        (GhcPass _) = NoExt
+type instance XOverLabel     (GhcPass _) = NoExt
+type instance XIPVar         (GhcPass _) = NoExt
+type instance XOverLitE      (GhcPass _) = NoExt
+type instance XLitE          (GhcPass _) = NoExt
+type instance XLam           (GhcPass _) = NoExt
+type instance XLamCase       (GhcPass _) = NoExt
+type instance XApp           (GhcPass _) = NoExt
+
+type instance XAppTypeE      GhcPs = LHsWcType GhcPs
+type instance XAppTypeE      GhcRn = LHsWcType GhcRn
+type instance XAppTypeE      GhcTc = LHsWcType GhcRn
+
+type instance XOpApp         GhcPs = NoExt
+type instance XOpApp         GhcRn = Fixity
+type instance XOpApp         GhcTc = Fixity
+
+type instance XNegApp        (GhcPass _) = NoExt
+type instance XPar           (GhcPass _) = NoExt
+type instance XSectionL      (GhcPass _) = NoExt
+type instance XSectionR      (GhcPass _) = NoExt
+type instance XExplicitTuple (GhcPass _) = NoExt
+
+type instance XExplicitSum   GhcPs = NoExt
+type instance XExplicitSum   GhcRn = NoExt
+type instance XExplicitSum   GhcTc = [Type]
+
+type instance XCase          (GhcPass _) = NoExt
+type instance XIf            (GhcPass _) = NoExt
+
+type instance XMultiIf       GhcPs = NoExt
+type instance XMultiIf       GhcRn = NoExt
+type instance XMultiIf       GhcTc = Type
+
+type instance XLet           (GhcPass _) = NoExt
+
+type instance XDo            GhcPs = NoExt
+type instance XDo            GhcRn = NoExt
+type instance XDo            GhcTc = Type
+
+type instance XExplicitList  GhcPs = NoExt
+type instance XExplicitList  GhcRn = NoExt
+type instance XExplicitList  GhcTc = Type
+
+type instance XRecordCon     GhcPs = NoExt
+type instance XRecordCon     GhcRn = NoExt
+type instance XRecordCon     GhcTc = RecordConTc
+
+type instance XRecordUpd     GhcPs = NoExt
+type instance XRecordUpd     GhcRn = NoExt
+type instance XRecordUpd     GhcTc = RecordUpdTc
+
+type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
+type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
+type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+
+type instance XArithSeq      GhcPs = NoExt
+type instance XArithSeq      GhcRn = NoExt
+type instance XArithSeq      GhcTc = PostTcExpr
+
+type instance XSCC           (GhcPass _) = NoExt
+type instance XCoreAnn       (GhcPass _) = NoExt
+type instance XBracket       (GhcPass _) = NoExt
+
+type instance XRnBracketOut  (GhcPass _) = NoExt
+type instance XTcBracketOut  (GhcPass _) = NoExt
+
+type instance XSpliceE       (GhcPass _) = NoExt
+type instance XProc          (GhcPass _) = NoExt
+
+type instance XStatic        GhcPs = NoExt
+type instance XStatic        GhcRn = NameSet
+type instance XStatic        GhcTc = NameSet
+
+type instance XArrApp        GhcPs = NoExt
+type instance XArrApp        GhcRn = NoExt
+type instance XArrApp        GhcTc = Type
+
+type instance XArrForm       (GhcPass _) = NoExt
+type instance XTick          (GhcPass _) = NoExt
+type instance XBinTick       (GhcPass _) = NoExt
+type instance XTickPragma    (GhcPass _) = NoExt
+type instance XEWildPat      (GhcPass _) = NoExt
+type instance XEAsPat        (GhcPass _) = NoExt
+type instance XEViewPat      (GhcPass _) = NoExt
+type instance XELazyPat      (GhcPass _) = NoExt
+type instance XWrap          (GhcPass _) = NoExt
+type instance XXExpr         (GhcPass _) = NoExt
+
+-- ---------------------------------------------------------------------
 
 -- | Located Haskell Tuple Argument
 --
@@ -716,13 +818,22 @@ type LHsTupArg id = Located (HsTupArg id)
 
 -- | Haskell Tuple Argument
 data HsTupArg id
-  = Present (LHsExpr id)     -- ^ The argument
-  | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
-deriving instance (DataId id) => Data (HsTupArg id)
+  = Present (XPresent id) (LHsExpr id)     -- ^ The argument
+  | Missing (XMissing id)    -- ^ The argument is missing, but this is its type
+  | XTupArg (XXTupArg id)    -- ^ Note [Trees that Grow] extension point
+
+type instance XPresent         (GhcPass _) = NoExt
+
+type instance XMissing         GhcPs = NoExt
+type instance XMissing         GhcRn = NoExt
+type instance XMissing         GhcTc = Type
+
+type instance XXTupArg         (GhcPass _) = NoExt
 
 tupArgPresent :: LHsTupArg id -> Bool
 tupArgPresent (L _ (Present {})) = True
 tupArgPresent (L _ (Missing {})) = False
+tupArgPresent (L _ (XTupArg {})) = False
 
 {-
 Note [Parens in HsSyn]
@@ -740,7 +851,7 @@ HsPar (and ParPat in patterns, HsParTy in types) is used as follows
     https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c
 
   * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or
-    not they are strictly necssary. This should be addressed when #13238 is
+    not they are strictly necessary. This should be addressed when #13238 is
     completed, to be treated the same as HsPar.
 
 
@@ -796,16 +907,16 @@ RenamedSource that the API Annotations cannot be used directly with
 RenamedSource, so this allows a simple mapping to be used based on the location.
 -}
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where
     ppr expr = pprExpr expr
 
 -----------------------
 -- pprExpr, pprLExpr, pprBinds call pprDeeper;
 -- the underscore versions do not
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
 pprLExpr (L _ e) = pprExpr e
 
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
 pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e
           | otherwise                           = pprDeeper (ppr_expr e)
 
@@ -813,60 +924,58 @@ isQuietHsExpr :: HsExpr id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsExpr (HsPar _)          = True
+isQuietHsExpr (HsPar {})        = True
 -- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _)        = True
-isQuietHsExpr (HsAppType _ _)    = True
-isQuietHsExpr (HsAppTypeOut _ _) = True
-isQuietHsExpr (OpApp _ _ _ _)    = True
+isQuietHsExpr (HsApp {})        = True
+isQuietHsExpr (HsAppType {})    = True
+isQuietHsExpr (OpApp {})        = True
 isQuietHsExpr _ = False
 
-pprBinds :: (SourceTextX idL, SourceTextX idR,
-             OutputableBndrId idL, OutputableBndrId idR)
-         => HsLocalBindsLR idL idR -> SDoc
+pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
 pprBinds b = pprDeeper (ppr b)
 
 -----------------------
-ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
 ppr_lexpr e = ppr_expr (unLoc e)
 
-ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
-ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
-ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
-ppr_expr (HsConLikeOut c) = pprPrefixOcc c
-ppr_expr (HsIPVar v)      = ppr v
-ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
-ppr_expr (HsLit lit)      = ppr lit
-ppr_expr (HsOverLit lit)  = ppr lit
-ppr_expr (HsPar e)        = parens (ppr_lexpr e)
-
-ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+ppr_expr :: forall p. (OutputableBndrId (GhcPass p))
+         => HsExpr (GhcPass p) -> SDoc
+ppr_expr (HsVar _ (L _ v))  = pprPrefixOcc v
+ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
+ppr_expr (HsIPVar _ v)      = ppr v
+ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l
+ppr_expr (HsLit _ lit)      = ppr lit
+ppr_expr (HsOverLit _ lit)  = ppr lit
+ppr_expr (HsPar _ e)        = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
   = vcat [pprWithSourceText stc (text "{-# CORE")
           <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
          , ppr_lexpr e]
 
 ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
-ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
 
-ppr_expr (OpApp e1 op _ e2)
+ppr_expr (OpApp _ e1 op e2)
   | Just pp_op <- should_print_infix (unLoc op)
   = pp_infixly pp_op
   | otherwise
   = pp_prefixly
 
   where
-    should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
-    should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
-    should_print_infix (HsRecFld f)    = Just (pprInfixOcc f)
-    should_print_infix (HsUnboundVar h@TrueExprHole{})
+    should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
+    should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
+    should_print_infix (HsRecFld _ f)    = Just (pprInfixOcc f)
+    should_print_infix (HsUnboundVar _ h@TrueExprHole{})
                                        = Just (pprInfixOcc (unboundVarOcc h))
-    should_print_infix EWildPat        = Just (text "`_`")
-    should_print_infix (HsWrap _ e)    = should_print_infix e
+    should_print_infix (EWildPat _)    = Just (text "`_`")
+    should_print_infix (HsWrap _ _ e)  = should_print_infix e
     should_print_infix _               = Nothing
 
-    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
-    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens
+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear
 
     pp_prefixly
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
@@ -874,63 +983,73 @@ ppr_expr (OpApp e1 op _ e2)
     pp_infixly pp_op
       = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
 
-ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
+ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
 
-ppr_expr (SectionL expr op)
+ppr_expr (SectionL _ expr op)
   = case unLoc op of
-      HsVar (L _ v)  -> pp_infixly v
-      HsConLikeOut c -> pp_infixly (conLikeName c)
-      _              -> pp_prefixly
+      HsVar _ (L _ v)  -> pp_infixly v
+      HsConLikeOut _ c -> pp_infixly (conLikeName c)
+      HsUnboundVar _ h@TrueExprHole{}
+                       -> pp_infixly (unboundVarOcc h)
+      _                -> pp_prefixly
   where
-    pp_expr = pprDebugParendExpr expr
+    pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, text "x_ )"])
+
+    pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
     pp_infixly v = (sep [pp_expr, pprInfixOcc v])
 
-ppr_expr (SectionR op expr)
+ppr_expr (SectionR _ op expr)
   = case unLoc op of
-      HsVar (L _ v)  -> pp_infixly v
-      HsConLikeOut c -> pp_infixly (conLikeName c)
-      _              -> pp_prefixly
+      HsVar _ (L _ v)  -> pp_infixly v
+      HsConLikeOut _ c -> pp_infixly (conLikeName c)
+      HsUnboundVar _ h@TrueExprHole{}
+                       -> pp_infixly (unboundVarOcc h)
+      _                -> pp_prefixly
   where
-    pp_expr = pprDebugParendExpr expr
+    pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
                        4 (pp_expr <> rparen)
+
+    pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
     pp_infixly v = sep [pprInfixOcc v, pp_expr]
 
-ppr_expr (ExplicitTuple exprs boxity)
+ppr_expr (ExplicitTuple _ exprs boxity)
   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
   where
     ppr_tup_args []               = []
-    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
-    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es
+    ppr_tup_args (XTupArg x   : es) = (ppr x <> punc es) : ppr_tup_args es
 
     punc (Present {} : _) = comma <> space
     punc (Missing {} : _) = comma
+    punc (XTupArg {} : _) = comma <> space
     punc []               = empty
 
-ppr_expr (ExplicitSum alt arity expr _)
+ppr_expr (ExplicitSum _ alt arity expr)
   = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
   where
     ppr_bars n = hsep (replicate n (char '|'))
 
-ppr_expr (HsLam matches)
+ppr_expr (HsLam _ matches)
   = pprMatches matches
 
-ppr_expr (HsLamCase matches)
+ppr_expr (HsLamCase _ matches)
   = sep [ sep [text "\\case"],
           nest 2 (pprMatches matches) ]
 
-ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
+ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
           nest 2 (pprMatches matches) <+> char '}']
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase _ expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_expr (HsIf _ e1 e2 e3)
+ppr_expr (HsIf _ _ e1 e2 e3)
   = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          text "else",
@@ -938,80 +1057,76 @@ ppr_expr (HsIf _ e1 e2 e3)
 
 ppr_expr (HsMultiIf _ alts)
   = hang (text "if") 3  (vcat (map ppr_alt alts))
-  where ppr_alt (L _ (GRHS guards expr)) =
+  where ppr_alt (L _ (GRHS _ guards expr)) =
           hang vbar 2 (ppr_one one_alt)
           where
             ppr_one [] = panic "ppr_exp HsMultiIf"
             ppr_one (h:t) = hang h 2 (sep t)
             one_alt = [ interpp'SP guards
                       , text "->" <+> pprDeeper (ppr expr) ]
+        ppr_alt (L _ (XGRHS x)) = ppr x
 
 -- special case: let ... in let ...
-ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
+ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))
   = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
          ppr_lexpr expr]
 
-ppr_expr (HsLet (L _ binds) expr)
+ppr_expr (HsLet _ (L _ binds) expr)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr expr)]
 
-ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
 
 ppr_expr (ExplicitList _ _ exprs)
   = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
 
-ppr_expr (ExplicitPArr _ exprs)
-  = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
-
 ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
   = hang (ppr con_id) 2 (ppr rbinds)
 
 ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
   = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
-ppr_expr (ExprWithTySig expr sig)
-  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
-         4 (ppr sig)
-ppr_expr (ExprWithTySigOut expr sig)
+ppr_expr (ExprWithTySig sig expr)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
 
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
-ppr_expr (PArrSeq  _ info) = paBrackets (ppr info)
 
-ppr_expr EWildPat       = char '_'
-ppr_expr (ELazyPat e)   = char '~' <> ppr e
-ppr_expr (EAsPat v e)   = ppr v <> char '@' <> ppr e
-ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
+ppr_expr (EWildPat _)     = char '_'
+ppr_expr (ELazyPat _ e)   = char '~' <> ppr e
+ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e
+ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
 
-ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
   = sep [ pprWithSourceText st (text "{-# SCC")
          -- no doublequotes if stl empty, for the case where the SCC was written
          -- without quotes.
           <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
           ppr expr ]
 
-ppr_expr (HsWrap co_fn e)
+ppr_expr (HsWrap _ co_fn e)
   = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
                                              else pprExpr e)
 
-ppr_expr (HsSpliceE s)         = pprSplice s
-ppr_expr (HsBracket b)         = pprHsBracket b
-ppr_expr (HsRnBracketOut e []) = ppr e
-ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut e []) = ppr e
-ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsSpliceE _ s)         = pprSplice s
+ppr_expr (HsBracket _ b)         = pprHsBracket b
+ppr_expr (HsRnBracketOut _ e []) = ppr e
+ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
+ppr_expr (HsTcBracketOut _ e []) = ppr e
+ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
 
-ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
+ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
   = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
+  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
 
 ppr_expr (HsStatic _ e)
   = hsep [text "static", ppr e]
 
-ppr_expr (HsTick tickish exp)
+ppr_expr (HsTick _ tickish exp)
   = pprTicks (ppr exp) $
     ppr tickish <+> ppr_lexpr exp
-ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
   = pprTicks (ppr exp) $
     hcat [text "bintick<",
           ppr tickIdTrue,
@@ -1019,7 +1134,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           text ">(",
           ppr exp, text ")"]
-ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
+ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
   = pprTicks (ppr exp) $
     hcat [text "tickpragma<",
           pprExternalSrcLoc externalSrcLoc,
@@ -1027,44 +1142,40 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
           ppr exp,
           text ")"]
 
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm op _ args)
+ppr_expr (HsArrForm _ op _ args)
   = hang (text "(|" <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
-ppr_expr (HsRecFld f) = ppr f
-
--- We must tiresomely make the "id" parameter to the LHsWcType existential
--- because it's different in the HsAppType case and the HsAppTypeOut case
--- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p)
-                       => LHsWcTypeX (LHsWcType p)
+ppr_expr (HsRecFld _ f) = ppr f
+ppr_expr (XExpr x) = ppr x
 
-ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p
-         -> [Either (LHsExpr p) LHsWcTypeX]
+ppr_apps :: (OutputableBndrId (GhcPass p))
+         => HsExpr (GhcPass p)
+         -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
          -> SDoc
-ppr_apps (HsApp (L _ fun) arg)        args
+ppr_apps (HsApp _ (L _ fun) arg)        args
   = ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType (L _ fun) arg)    args
-  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
-ppr_apps (HsAppTypeOut (L _ fun) arg) args
-  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppType arg (L _ fun))    args
+  = ppr_apps fun (Right arg : args)
 ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
   where
     pp (Left arg)                             = ppr arg
-    pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
-      = char '@' <> pprHsType arg
+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+    --   = char '@' <> pprHsType arg
+    pp (Right arg)
+      = char '@' <> ppr arg
 
 pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
 pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -1082,50 +1193,87 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
 can see the structure of the parse tree.
 -}
 
-pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
-pprDebugParendExpr expr
+pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprDebugParendExpr p expr
   = getPprStyle (\sty ->
-    if debugStyle sty then pprParendLExpr expr
+    if debugStyle sty then pprParendLExpr p expr
                       else pprLExpr      expr)
 
-pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
-pprParendLExpr (L _ e) = pprParendExpr e
+pprParendLExpr :: (OutputableBndrId (GhcPass p))
+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprParendLExpr p (L _ e) = pprParendExpr p e
 
-pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
-pprParendExpr expr
-  | hsExprNeedsParens expr = parens (pprExpr expr)
-  | otherwise              = pprExpr expr
+pprParendExpr :: (OutputableBndrId (GhcPass p))
+              => PprPrec -> HsExpr (GhcPass p) -> SDoc
+pprParendExpr p expr
+  | hsExprNeedsParens p expr = parens (pprExpr expr)
+  | otherwise                = pprExpr expr
         -- Using pprLExpr makes sure that we go 'deeper'
         -- I think that is usually (always?) right
 
-hsExprNeedsParens :: HsExpr id -> Bool
--- True of expressions for which '(e)' and 'e'
--- mean the same thing
-hsExprNeedsParens (ArithSeq {})       = False
-hsExprNeedsParens (PArrSeq {})        = False
-hsExprNeedsParens (HsLit {})          = False
-hsExprNeedsParens (HsOverLit {})      = False
-hsExprNeedsParens (HsVar {})          = False
-hsExprNeedsParens (HsUnboundVar {})   = False
-hsExprNeedsParens (HsConLikeOut {})   = False
-hsExprNeedsParens (HsIPVar {})        = False
-hsExprNeedsParens (HsOverLabel {})    = False
-hsExprNeedsParens (ExplicitTuple {})  = False
-hsExprNeedsParens (ExplicitList {})   = False
-hsExprNeedsParens (ExplicitPArr {})   = False
-hsExprNeedsParens (HsPar {})          = False
-hsExprNeedsParens (HsBracket {})      = False
-hsExprNeedsParens (HsRnBracketOut {}) = False
-hsExprNeedsParens (HsTcBracketOut {}) = False
-hsExprNeedsParens (HsDo sc _ _)
-       | isListCompExpr sc            = False
-hsExprNeedsParens (HsRecFld{})        = False
-hsExprNeedsParens (RecordCon{})       = False
-hsExprNeedsParens (HsSpliceE{})       = False
-hsExprNeedsParens (RecordUpd{})       = False
-hsExprNeedsParens (HsWrap _ e)        = hsExprNeedsParens e
-hsExprNeedsParens _ = True
-
+-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
+-- parentheses under precedence @p@.
+hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
+hsExprNeedsParens p = go
+  where
+    go (HsVar{})                      = False
+    go (HsUnboundVar{})               = False
+    go (HsConLikeOut{})               = False
+    go (HsIPVar{})                    = False
+    go (HsOverLabel{})                = False
+    go (HsLit _ l)                    = hsLitNeedsParens p l
+    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol
+    go (HsPar{})                      = False
+    go (HsCoreAnn _ _ _ (L _ e))      = go e
+    go (HsApp{})                      = p >= appPrec
+    go (HsAppType {})                 = p >= appPrec
+    go (OpApp{})                      = p >= opPrec
+    go (NegApp{})                     = p > topPrec
+    go (SectionL{})                   = True
+    go (SectionR{})                   = True
+    go (ExplicitTuple{})              = False
+    go (ExplicitSum{})                = False
+    go (HsLam{})                      = p > topPrec
+    go (HsLamCase{})                  = p > topPrec
+    go (HsCase{})                     = p > topPrec
+    go (HsIf{})                       = p > topPrec
+    go (HsMultiIf{})                  = p > topPrec
+    go (HsLet{})                      = p > topPrec
+    go (HsDo _ sc _)
+      | isComprehensionContext sc     = False
+      | otherwise                     = p > topPrec
+    go (ExplicitList{})               = False
+    go (RecordUpd{})                  = False
+    go (ExprWithTySig{})              = p > topPrec
+    go (ArithSeq{})                   = False
+    go (EWildPat{})                   = False
+    go (ELazyPat{})                   = False
+    go (EAsPat{})                     = False
+    go (EViewPat{})                   = True
+    go (HsSCC{})                      = p >= appPrec
+    go (HsWrap _ _ e)                 = go e
+    go (HsSpliceE{})                  = False
+    go (HsBracket{})                  = False
+    go (HsRnBracketOut{})             = False
+    go (HsTcBracketOut{})             = False
+    go (HsProc{})                     = p > topPrec
+    go (HsStatic{})                   = p >= appPrec
+    go (HsTick _ _ (L _ e))           = go e
+    go (HsBinTick _ _ _ (L _ e))      = go e
+    go (HsTickPragma _ _ _ _ (L _ e)) = go e
+    go (HsArrApp{})                   = True
+    go (HsArrForm{})                  = True
+    go (RecordCon{})                  = False
+    go (HsRecFld{})                   = False
+    go (XExpr{})                      = True
+
+-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
+parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+parenthesizeHsExpr p le@(L loc e)
+  | hsExprNeedsParens p e = L loc (HsPar NoExt le)
+  | otherwise             = le
 
 isAtomicHsExpr :: HsExpr id -> Bool
 -- True of a single token
@@ -1136,8 +1284,8 @@ isAtomicHsExpr (HsOverLit {})    = True
 isAtomicHsExpr (HsIPVar {})      = True
 isAtomicHsExpr (HsOverLabel {})  = True
 isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e
-isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsWrap _ _ e)    = isAtomicHsExpr e
+isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr _                 = False
 
@@ -1162,10 +1310,10 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
+        (XCmdArrApp id)  -- type of the arrow expressions f,
+                         -- of the form a t t', where arg :: t
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
-        (PostTc id Type) -- type of the arrow expressions f,
-                         -- of the form a t t', where arg :: t
         HsArrAppType     -- higher-order (-<<) or first-order (-<)
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
@@ -1175,6 +1323,7 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
+        (XCmdArrForm id)
         (LHsExpr id)     -- The operator.
                          -- After type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
@@ -1184,22 +1333,26 @@ data HsCmd id
                          -- were converted from OpApp's by the renamer
         [LHsCmdTop id]   -- argument commands
 
-  | HsCmdApp    (LHsCmd id)
+  | HsCmdApp    (XCmdApp id)
+                (LHsCmd id)
                 (LHsExpr id)
 
-  | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
+  | HsCmdLam    (XCmdLam id)
+                (MatchGroup id (LHsCmd id))     -- kappa
        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --       'ApiAnnotation.AnnRarrow',
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdPar    (LHsCmd id)                     -- parenthesised command
+  | HsCmdPar    (XCmdPar id)
+                (LHsCmd id)                     -- parenthesised command
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
     --             'ApiAnnotation.AnnClose' @')'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdCase   (LHsExpr id)
+  | HsCmdCase   (XCmdCase id)
+                (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
     --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
@@ -1207,7 +1360,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
+  | HsCmdIf     (XCmdIf id)
+                (Maybe (SyntaxExpr id))         -- cond function
                 (LHsExpr id)                    -- predicate
                 (LHsCmd id)                     -- then part
                 (LHsCmd id)                     -- else part
@@ -1218,7 +1372,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdLet    (LHsLocalBinds id)      -- let(rec)
+  | HsCmdLet    (XCmdLet id)
+                (LHsLocalBinds id)      -- let(rec)
                 (LHsCmd  id)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
     --       'ApiAnnotation.AnnOpen' @'{'@,
@@ -1226,8 +1381,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdDo     (Located [CmdLStmt id])
-                (PostTc id Type)                -- Type of the whole expression
+  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression
+                (Located [CmdLStmt id])
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
     --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
     --             'ApiAnnotation.AnnVbar',
@@ -1235,11 +1390,31 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdWrap   HsWrapper
+  | HsCmdWrap   (XCmdWrap id)
+                HsWrapper
                 (HsCmd id)     -- If   cmd :: arg1 --> res
                                --      wrap :: arg1 "->" arg2
                                -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
-deriving instance (DataId id) => Data (HsCmd id)
+  | XCmd        (XXCmd id)     -- Note [Trees that Grow] extension point
+
+type instance XCmdArrApp  GhcPs = NoExt
+type instance XCmdArrApp  GhcRn = NoExt
+type instance XCmdArrApp  GhcTc = Type
+
+type instance XCmdArrForm (GhcPass _) = NoExt
+type instance XCmdApp     (GhcPass _) = NoExt
+type instance XCmdLam     (GhcPass _) = NoExt
+type instance XCmdPar     (GhcPass _) = NoExt
+type instance XCmdCase    (GhcPass _) = NoExt
+type instance XCmdIf      (GhcPass _) = NoExt
+type instance XCmdLet     (GhcPass _) = NoExt
+
+type instance XCmdDo      GhcPs = NoExt
+type instance XCmdDo      GhcRn = NoExt
+type instance XCmdDo      GhcTc = Type
+
+type instance XCmdWrap    (GhcPass _) = NoExt
+type instance XXCmd       (GhcPass _) = NoExt
 
 -- | Haskell Array Application Type
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1256,22 +1431,31 @@ type LHsCmdTop p = Located (HsCmdTop p)
 
 -- | Haskell Top-level Command
 data HsCmdTop p
-  = HsCmdTop (LHsCmd p)
-             (PostTc p Type)    -- Nested tuple of inputs on the command's stack
-             (PostTc p Type)    -- return type of the command
-             (CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
-deriving instance (DataId p) => Data (HsCmdTop p)
+  = HsCmdTop (XCmdTop p)
+             (LHsCmd p)
+  | XCmdTop (XXCmdTop p)        -- Note [Trees that Grow] extension point
+
+data CmdTopTc
+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack
+             Type    -- return type of the command
+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
+
+type instance XCmdTop  GhcPs = NoExt
+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
+type instance XCmdTop  GhcTc = CmdTopTc
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where
+type instance XXCmdTop (GhcPass _) = NoExt
+
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
     ppr cmd = pprCmd cmd
 
 -----------------------
 -- pprCmd and pprLCmd call pprDeeper;
 -- the underscore versions do not
-pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
 pprLCmd (L _ c) = pprCmd c
 
-pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
 pprCmd c | isQuietHsCmd c =            ppr_cmd c
          | otherwise      = pprDeeper (ppr_cmd c)
 
@@ -1279,81 +1463,83 @@ isQuietHsCmd :: HsCmd id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsCmd (HsCmdPar _) = True
+isQuietHsCmd (HsCmdPar {}) = True
 -- applications don't display anything themselves
-isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd (HsCmdApp {}) = True
 isQuietHsCmd _ = False
 
 -----------------------
-ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
 ppr_lcmd c = ppr_cmd (unLoc c)
 
-ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)
 
-ppr_cmd (HsCmdApp c e)
+ppr_cmd (HsCmdApp _ c e)
   = let (fun, args) = collect_args c [e] in
     hang (ppr_lcmd fun) 2 (sep (map ppr args))
   where
-    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)
     collect_args fun args = (fun, args)
 
-ppr_cmd (HsCmdLam matches)
+ppr_cmd (HsCmdLam _ matches)
   = pprMatches matches
 
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase _ expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_cmd (HsCmdIf _ e ct ce)
+ppr_cmd (HsCmdIf _ _ e ct ce)
   = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
          nest 4 (ppr ct),
          text "else",
          nest 4 (ppr ce)]
 
 -- special case: let ... in let ...
-ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
   = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
          ppr_lcmd cmd]
 
-ppr_cmd (HsCmdLet (L _ binds) cmd)
+ppr_cmd (HsCmdLet _ (L _ binds) cmd)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr cmd)]
 
-ppr_cmd (HsCmdDo (L _ stmts) _)  = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts
 
-ppr_cmd (HsCmdWrap w cmd)
+ppr_cmd (HsCmdWrap _ w cmd)
   = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm op _ _ args)
+ppr_cmd (HsCmdArrForm _ op _ _ args)
   = hang (text "(|" <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+ppr_cmd (XCmd x) = ppr x
 
-pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
+pprCmdArg (HsCmdTop _ cmd)
   = ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
     ppr = pprCmdArg
 
 {-
@@ -1390,14 +1576,25 @@ patterns in each equation.
 -}
 
 data MatchGroup p body
-  = MG { mg_alts    :: Located [LMatch p body]  -- The alternatives
-       , mg_arg_tys :: [PostTc p Type]  -- Types of the arguments, t1..tn
-       , mg_res_ty  :: PostTc p Type    -- Type of the result, tr
+  = MG { mg_ext     :: XMG p body -- Posr typechecker, types of args and result
+       , mg_alts    :: Located [LMatch p body]  -- The alternatives
        , mg_origin  :: Origin }
      -- The type is the type of the entire group
      --      t1 -> ... -> tn -> tr
      -- where there are n patterns
-deriving instance (Data body,DataId p) => Data (MatchGroup p body)
+  | XMatchGroup (XXMatchGroup p body)
+
+data MatchGroupTc
+  = MatchGroupTc
+       { mg_arg_tys :: [Type]  -- Types of the arguments, t1..tn
+       , mg_res_ty  :: Type    -- Type of the result, tr
+       } deriving Data
+
+type instance XMG         GhcPs b = NoExt
+type instance XMG         GhcRn b = NoExt
+type instance XMG         GhcTc b = MatchGroupTc
+
+type instance XXMatchGroup (GhcPass _) b = NoExt
 
 -- | Located Match
 type LMatch id body = Located (Match id body)
@@ -1407,18 +1604,18 @@ type LMatch id body = Located (Match id body)
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Match p body
   = Match {
+        m_ext :: XCMatch p body,
         m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),
           -- See note [m_ctxt in Match]
         m_pats :: [LPat p], -- The patterns
-        m_type :: (Maybe (LHsType p)),
-                                 -- A type signature for the result of the match
-                                 -- Nothing after typechecking
-                                 -- NB: No longer supported
         m_grhss :: (GRHSs p body)
   }
-deriving instance (Data body,DataId p) => Data (Match p body)
+  | XMatch (XXMatch p body)
+
+type instance XCMatch (GhcPass _) b = NoExt
+type instance XXMatch (GhcPass _) b = NoExt
 
-instance (SourceTextX idR, OutputableBndrId idR, Outputable body)
+instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
             => Outputable (Match idR body) where
   ppr = pprMatch
 
@@ -1466,6 +1663,7 @@ isInfixMatch match = case m_ctxt match of
 
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
+isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup"
 
 -- | Is there only one RHS in this list of matches?
 isSingletonMatchGroup :: [LMatch id body] -> Bool
@@ -1482,9 +1680,11 @@ matchGroupArity :: MatchGroup id body -> Arity
 matchGroupArity (MG { mg_alts = alts })
   | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
   | otherwise        = panic "matchGroupArity"
+matchGroupArity (XMatchGroup{}) = panic "matchGroupArity"
 
 hsLMatchPats :: LMatch id body -> [LPat id]
-hsLMatchPats (L _ (Match _ pats _ _)) = pats
+hsLMatchPats (L _ (Match { m_pats = pats })) = pats
+hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats"
 
 -- | Guarded Right-Hand Sides
 --
@@ -1498,46 +1698,54 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats
 -- For details on above see note [Api annotations] in ApiAnnotation
 data GRHSs p body
   = GRHSs {
+      grhssExt :: XCGRHSs p body,
       grhssGRHSs :: [LGRHS p body],      -- ^ Guarded RHSs
       grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
     }
-deriving instance (Data body,DataId p) => Data (GRHSs p body)
+  | XGRHSs (XXGRHSs p body)
+
+type instance XCGRHSs (GhcPass _) b = NoExt
+type instance XXGRHSs (GhcPass _) b = NoExt
 
 -- | Located Guarded Right-Hand Side
 type LGRHS id body = Located (GRHS id body)
 
 -- | Guarded Right Hand Side.
-data GRHS id body = GRHS [GuardLStmt id] -- Guards
-                         body            -- Right hand side
-deriving instance (Data body,DataId id) => Data (GRHS id body)
+data GRHS p body = GRHS (XCGRHS p body)
+                        [GuardLStmt p] -- Guards
+                        body           -- Right hand side
+                  | XGRHS (XXGRHS p body)
+
+type instance XCGRHS (GhcPass _) b = NoExt
+type instance XXGRHS (GhcPass _) b = NoExt
 
 -- We know the list must have at least one @Match@ in it.
 
-pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-           => MatchGroup idR body -> SDoc
+pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body)
+           => MatchGroup (GhcPass idR) body -> SDoc
 pprMatches MG { mg_alts = matches }
     = vcat (map pprMatch (map unLoc (unLoc matches)))
       -- Don't print the type; it's only a place-holder before typechecking
+pprMatches (XMatchGroup x) = ppr x
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-           => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+           => MatchGroup (GhcPass idR) body -> SDoc
 pprFunBind matches = pprMatches matches
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
-                                   OutputableBndrId bndr,
-                                   OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+                                   OutputableBndrId (GhcPass p),
                                    Outputable body)
-           => LPat bndr -> GRHSs p body -> SDoc
+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
 pprPatBind pat (grhss)
- = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)]
+ = sep [ppr pat,
+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
 
-pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-         => Match idR body -> SDoc
+pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
+         => Match (GhcPass idR) body -> SDoc
 pprMatch match
-  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
-        , nest 2 ppr_maybe_ty
+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
         , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
   where
     ctxt = m_ctxt match
@@ -1558,37 +1766,40 @@ pprMatch match
                 | otherwise -> (parens pp_infix, pats2)
                         -- (x &&& y) z = e
                 where
-                  pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
+                  pp_infix = pprParendLPat opPrec pat1
+                         <+> pprInfixOcc fun
+                         <+> pprParendLPat opPrec pat2
 
             LambdaExpr -> (char '\\', m_pats match)
 
-            _  -> ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
-                  (ppr pat1, [])        -- No parens around the single pat
+            _  -> if null (m_pats match)
+                     then (empty, [])
+                     else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )
+                          (ppr pat1, [])        -- No parens around the single pat
 
     (pat1:pats1) = m_pats match
     (pat2:pats2) = pats1
-    ppr_maybe_ty = case m_type match of
-                        Just ty -> dcolon <+> ppr ty
-                        Nothing -> empty
-
 
-pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-         => HsMatchContext idL -> GRHSs idR body -> SDoc
-pprGRHSs ctxt (GRHSs grhss (L _ binds))
+pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body)
+         => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
+pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
   = vcat (map (pprGRHS ctxt . unLoc) grhss)
   -- Print the "where" even if the contents of the binds is empty. Only
   -- EmptyLocalBinds means no "where" keyword
  $$ ppUnless (eqEmptyLocalBinds binds)
       (text "where" $$ nest 4 (pprBinds binds))
+pprGRHSs _ (XGRHSs x) = ppr x
 
-pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-        => HsMatchContext idL -> GRHS idR body -> SDoc
-pprGRHS ctxt (GRHS [] body)
+pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body)
+        => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
+pprGRHS ctxt (GRHS _ [] body)
  =  pp_rhs ctxt body
 
-pprGRHS ctxt (GRHS guards body)
+pprGRHS ctxt (GRHS _ guards body)
  = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
 
+pprGRHS _ (XGRHS x) = ppr x
+
 pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
 pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
 
@@ -1643,30 +1854,30 @@ type GhciStmt   id = Stmt  id (LHsExpr id)
 
 -- For details on above see note [Api annotations] in ApiAnnotation
 data StmtLR idL idR body -- body should always be (LHs**** idR)
-  = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp,
-              -- and (after the renamer) DoExpr, MDoExpr
+  = LastStmt  -- Always the last Stmt in ListComp, MonadComp,
+              -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr
               -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff
+          (XLastStmt idL idR body)
           body
           Bool               -- True <=> return was stripped by ApplicativeDo
-          (SyntaxExpr idR)   -- The return operator, used only for
-                             -- MonadComp For ListComp, PArrComp, we
-                             -- use the baked-in 'return' For DoExpr,
-                             -- MDoExpr, we don't apply a 'return' at
-                             -- all See Note [Monad Comprehensions] |
-                             -- - 'ApiAnnotation.AnnKeywordId' :
-                             -- 'ApiAnnotation.AnnLarrow'
+          (SyntaxExpr idR)   -- The return operator
+            -- The return operator is used only for MonadComp
+            -- For ListComp we use the baked-in 'return'
+            -- For DoExpr, MDoExpr, we don't apply a 'return' at all
+            -- See Note [Monad Comprehensions]
+            -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | BindStmt (LPat idL)
+  | BindStmt (XBindStmt idL idR body) -- Post typechecking,
+                                -- result type of the function passed to bind;
+                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
+             (LPat idL)
              body
              (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
              (SyntaxExpr idR) -- The fail operator
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
-             (PostTc idR Type)  -- result type of the function passed to bind;
-                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
-
   -- | 'ApplicativeStmt' represents an applicative expression built with
   -- <$> and <*>.  It is generated by the renamer, and is desugared into the
   -- appropriate applicative expression by the desugarer, but it is intended
@@ -1675,34 +1886,38 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
   -- For full details, see Note [ApplicativeDo] in RnExpr
   --
   | ApplicativeStmt
+             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body
              [ ( SyntaxExpr idR
-               , ApplicativeArg idL idR) ]
+               , ApplicativeArg idL) ]
                       -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
              (Maybe (SyntaxExpr idR))  -- 'join', if necessary
-             (PostTc idR Type)     -- Type of the body
 
-  | BodyStmt body              -- See Note [BodyStmt]
+  | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type
+                                      -- of the RHS (used for arrows)
+             body              -- See Note [BodyStmt]
              (SyntaxExpr idR)  -- The (>>) operator
              (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp
                                -- See notes [Monad Comprehensions]
-             (PostTc idR Type) -- Element type of the RHS (used for arrows)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'
   --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | LetStmt  (LHsLocalBindsLR idL idR)
+  | LetStmt  (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
-  | ParStmt  [ParStmtBlock idL idR]
+  | ParStmt  (XParStmt idL idR body)    -- Post typecheck,
+                                        -- S in (>>=) :: Q -> (R -> S) -> T
+             [ParStmtBlock idL idR]
              (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions
              (SyntaxExpr idR)           -- The `>>=` operator
                                         -- See notes [Monad Comprehensions]
-             (PostTc idR Type)          -- S in (>>=) :: Q -> (R -> S) -> T
             -- After renaming, the ids are the binders
             -- bound by the stmts and used after themp
 
   | TransStmt {
+      trS_ext   :: XTransStmt idL idR body, -- Post typecheck,
+                                            -- R in (>>=) :: Q -> (R -> S) -> T
       trS_form  :: TransForm,
       trS_stmts :: [ExprLStmt idL],   -- Stmts to the *left* of the 'group'
                                       -- which generates the tuples to be grouped
@@ -1716,7 +1931,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
       trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for
                                       -- the inner monad comprehensions
       trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator
-      trS_bind_arg_ty :: PostTc idR Type,  -- R in (>>=) :: Q -> (R -> S) -> T
       trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring
                                       -- Only for 'group' forms
                                       -- Just a simple HsExpr, because it's
@@ -1728,7 +1942,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecStmt
-     { recS_stmts :: [LStmtLR idL idR body]
+     { recS_ext :: XRecStmt idL idR body
+     , recS_stmts :: [LStmtLR idL idR body]
 
         -- The next two fields are only valid after renaming
      , recS_later_ids :: [IdP idR]
@@ -1747,26 +1962,59 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
      , recS_bind_fn :: SyntaxExpr idR -- The bind function
      , recS_ret_fn  :: SyntaxExpr idR -- The return function
      , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
-     , recS_bind_ty :: PostTc idR Type  -- S in (>>=) :: Q -> (R -> S) -> T
+      }
+  | XStmtLR (XXStmtLR idL idR body)
 
-        -- These fields are only valid after typechecking
+-- Extra fields available post typechecking for RecStmt.
+data RecStmtTc =
+  RecStmtTc
+     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T
      , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
      , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
-                                     -- with recS_later_ids and recS_rec_ids,
-                                     -- and are the expressions that should be
-                                     -- returned by the recursion.
-                                     -- They may not quite be the Ids themselves,
-                                     -- because the Id may be *polymorphic*, but
-                                     -- the returned thing has to be *monomorphic*,
-                                     -- so they may be type applications
-
-      , recS_ret_ty :: PostTc idR Type -- The type of
-                                       -- do { stmts; return (a,b,c) }
+                                  -- with recS_later_ids and recS_rec_ids,
+                                  -- and are the expressions that should be
+                                  -- returned by the recursion.
+                                  -- They may not quite be the Ids themselves,
+                                  -- because the Id may be *polymorphic*, but
+                                  -- the returned thing has to be *monomorphic*,
+                                  -- so they may be type applications
+
+      , recS_ret_ty :: Type        -- The type of
+                                   -- do { stmts; return (a,b,c) }
                                    -- With rebindable syntax the type might not
                                    -- be quite as simple as (m (tya, tyb, tyc)).
       }
-deriving instance (Data body, DataId idL, DataId idR)
-  => Data (StmtLR idL idR body)
+
+
+type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExt
+
+type instance XBindStmt        (GhcPass _) GhcPs b = NoExt
+type instance XBindStmt        (GhcPass _) GhcRn b = NoExt
+type instance XBindStmt        (GhcPass _) GhcTc b = Type
+
+type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt
+type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt
+type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
+
+type instance XBodyStmt        (GhcPass _) GhcPs b = NoExt
+type instance XBodyStmt        (GhcPass _) GhcRn b = NoExt
+type instance XBodyStmt        (GhcPass _) GhcTc b = Type
+
+type instance XLetStmt         (GhcPass _) (GhcPass _) b = NoExt
+
+type instance XParStmt         (GhcPass _) GhcPs b = NoExt
+type instance XParStmt         (GhcPass _) GhcRn b = NoExt
+type instance XParStmt         (GhcPass _) GhcTc b = Type
+
+type instance XTransStmt       (GhcPass _) GhcPs b = NoExt
+type instance XTransStmt       (GhcPass _) GhcRn b = NoExt
+type instance XTransStmt       (GhcPass _) GhcTc b = Type
+
+type instance XRecStmt         (GhcPass _) GhcPs b = NoExt
+type instance XRecStmt         (GhcPass _) GhcRn b = NoExt
+type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc
+
+type instance XXStmtLR         (GhcPass _) (GhcPass _) b = NoExt
 
 data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function
   = ThenForm     -- then f               or    then f by e             (depending on trS_by)
@@ -1776,21 +2024,35 @@ data TransForm   -- The 'f' below is the 'using' function, 'e' is the by functio
 -- | Parenthesised Statement Block
 data ParStmtBlock idL idR
   = ParStmtBlock
+        (XParStmtBlock idL idR)
         [ExprLStmt idL]
         [IdP idR]          -- The variables to be returned
         (SyntaxExpr idR)   -- The return operator
-deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
+  | XParStmtBlock (XXParStmtBlock idL idR)
+
+type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExt
+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt
 
 -- | Applicative Argument
-data ApplicativeArg idL idR
-  = ApplicativeArgOne            -- pat <- expr (pat must be irrefutable)
-      (LPat idL)
+data ApplicativeArg idL
+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
+      (XApplicativeArgOne idL)
+      (LPat idL)           -- WildPat if it was a BodyStmt (see below)
       (LHsExpr idL)
-  | ApplicativeArgMany           -- do { stmts; return vars }
-      [ExprLStmt idL]            -- stmts
-      (HsExpr idL)               -- return (v1,..,vn), or just (v1,..,vn)
-      (LPat idL)                 -- (v1,...,vn)
-deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+      Bool                 -- True <=> was a BodyStmt
+                           -- False <=> was a BindStmt
+                           -- See Note [Applicative BodyStmt]
+
+  | ApplicativeArgMany     -- do { stmts; return vars }
+      (XApplicativeArgMany idL)
+      [ExprLStmt idL]      -- stmts
+      (HsExpr idL)         -- return (v1,..,vn), or just (v1,..,vn)
+      (LPat idL)           -- (v1,...,vn)
+  | XApplicativeArg (XXApplicativeArg idL)
+
+type instance XApplicativeArgOne  (GhcPass _) = NoExt
+type instance XApplicativeArgMany (GhcPass _) = NoExt
+type instance XXApplicativeArg    (GhcPass _) = NoExt
 
 {-
 Note [The type of bind in Stmts]
@@ -1927,41 +2189,73 @@ Parallel statements require the 'Control.Monad.Zip.mzip' function:
 
 In any other context than 'MonadComp', the fields for most of these
 'SyntaxExpr's stay bottom.
+
+
+Note [Applicative BodyStmt]
+
+(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt
+as if it was a BindStmt with a wildcard pattern.  For example,
+
+  do
+    x <- A
+    B
+    return x
+
+is transformed as if it were
+
+  do
+    x <- A
+    _ <- B
+    return x
+
+so it transforms to
+
+  (\(x,_) -> x) <$> A <*> B
+
+But we have to remember when we treat a BodyStmt like a BindStmt,
+because in error messages we want to emit the original syntax the user
+wrote, not our internal representation.  So ApplicativeArgOne has a
+Bool flag that is True when the original statement was a BodyStmt, so
+that we can pretty-print it correctly.
 -}
 
-instance (SourceTextX idL, OutputableBndrId idL)
-       => Outputable (ParStmtBlock idL idR) where
-  ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+instance (Outputable (StmtLR idL idL (LHsExpr idL)),
+          Outputable (XXParStmtBlock idL idR))
+        => Outputable (ParStmtBlock idL idR) where
+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+  ppr (XParStmtBlock x)          = ppr x
 
-instance (SourceTextX idL, SourceTextX idR,
-          OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
+          OutputableBndrId idL, OutputableBndrId idR,
+          Outputable body)
          => Outputable (StmtLR idL idR body) where
     ppr stmt = pprStmt stmt
 
-pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR,
-                                  OutputableBndrId idL, OutputableBndrId idR,
+pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL),
+                                  OutputableBndrId (GhcPass idR),
                                   Outputable body)
-        => (StmtLR idL idR body) -> SDoc
-pprStmt (LastStmt expr ret_stripped _)
-  = ifPprDebug (text "[last]") <+>
+        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
+pprStmt (LastStmt _ expr ret_stripped _)
+  = whenPprDebug (text "[last]") <+>
        (if ret_stripped then text "return" else empty) <+>
        ppr expr
-pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr]
-pprStmt (LetStmt (L _ binds))     = hsep [text "let", pprBinds binds]
-pprStmt (BodyStmt expr _ _ _)     = ppr expr
-pprStmt (ParStmt stmtss _ _ _)    = sep (punctuate (text " | ") (map ppr stmtss))
+pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]
+pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds]
+pprStmt (BodyStmt _ expr _ _)     = ppr expr
+pprStmt (ParStmt _ stmtss _ _)   = sep (punctuate (text " | ") (map ppr stmtss))
 
-pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
+                   , trS_using = using, trS_form = form })
   = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
 
 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
                  , recS_later_ids = later_ids })
   = text "rec" <+>
     vcat [ ppr_do_stmts segment
-         , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
+         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
                             , text "later_ids=" <> ppr later_ids])]
 
-pprStmt (ApplicativeStmt args mb_join _)
+pprStmt (ApplicativeStmt _ args mb_join)
   = getPprStyle $ \style ->
       if userStyle style
          then pp_for_user
@@ -1975,15 +2269,21 @@ pprStmt (ApplicativeStmt args mb_join _)
    -- ppr directly rather than transforming here, because we need to
    -- inject a "return" which is hard when we're polymorphic in the id
    -- type.
-   flattenStmt :: ExprLStmt idL -> [SDoc]
-   flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
+   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
+   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args
    flattenStmt stmt = [ppr stmt]
 
-   flattenArg (_, ApplicativeArgOne pat expr) =
-     [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
-             :: ExprStmt idL)]
-   flattenArg (_, ApplicativeArgMany stmts _ _) =
+   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
+   flattenArg (_, ApplicativeArgOne _ pat expr isBody)
+     | isBody =  -- See Note [Applicative BodyStmt]
+     [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+             :: ExprStmt (GhcPass idL))]
+     | otherwise =
+     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+             :: ExprStmt (GhcPass idL))]
+   flattenArg (_, ApplicativeArgMany _ stmts _ _) =
      concatMap flattenStmt stmts
+   flattenArg (_, XApplicativeArg _) = panic "flattenArg"
 
    pp_debug =
      let
@@ -1993,20 +2293,29 @@ pprStmt (ApplicativeStmt args mb_join _)
           then ap_expr
           else text "join" <+> parens ap_expr
 
-   pp_arg (_, ApplicativeArgOne pat expr) =
-     ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
-            :: ExprStmt idL)
-   pp_arg (_, ApplicativeArgMany stmts return pat) =
+   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
+   pp_arg (_, ApplicativeArgOne _ pat expr isBody)
+     | isBody =  -- See Note [Applicative BodyStmt]
+     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
+            :: ExprStmt (GhcPass idL))
+     | otherwise =
+     ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
+            :: ExprStmt (GhcPass idL))
+   pp_arg (_, ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>
-     ppr (HsDo DoExpr (noLoc
-                (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
-           (error "pprStmt"))
+     ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+               (stmts ++
+                   [noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)])))
+   pp_arg (_, XApplicativeArg x) = ppr x
+
+pprStmt (XStmtLR x) = ppr x
 
-pprTransformStmt :: (SourceTextX p, OutputableBndrId p)
-                 => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc
+pprTransformStmt :: (OutputableBndrId (GhcPass p))
+                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
+                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc
 pprTransformStmt bndrs using by
-  = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs))
+  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
         , nest 2 (ppr using)
         , nest 2 (pprBy by)]
 
@@ -2020,27 +2329,26 @@ pprBy :: Outputable body => Maybe body -> SDoc
 pprBy Nothing  = empty
 pprBy (Just e) = text "by" <+> ppr e
 
-pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body)
-      => HsStmtContext any -> [LStmt p body] -> SDoc
+pprDo :: (OutputableBndrId (GhcPass p), Outputable body)
+      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
 pprDo DoExpr        stmts = text "do"  <+> ppr_do_stmts stmts
 pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts
 pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts
 pprDo MDoExpr       stmts = text "mdo" <+> ppr_do_stmts stmts
 pprDo ListComp      stmts = brackets    $ pprComp stmts
-pprDo PArrComp      stmts = paBrackets  $ pprComp stmts
 pprDo MonadComp     stmts = brackets    $ pprComp stmts
 pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt
 
-ppr_do_stmts :: (SourceTextX idL, SourceTextX idR,
-                 OutputableBndrId idL, OutputableBndrId idR, Outputable body)
-             => [LStmtLR idL idR body] -> SDoc
+ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+                 Outputable body)
+             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
 -- Print a bunch of do stmts
 ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
 
-pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body)
-        => [LStmt p body] -> SDoc
+pprComp :: (OutputableBndrId (GhcPass p), Outputable body)
+        => [LStmt (GhcPass p) body] -> SDoc
 pprComp quals     -- Prints:  body | qual1, ..., qualn
-  | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
+  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals
   = if null initStmts
        -- If there are no statements in a list comprehension besides the last
        -- one, we simply treat it like a normal list. This does arise
@@ -2052,8 +2360,8 @@ pprComp quals     -- Prints:  body | qual1, ..., qualn
   | otherwise
   = pprPanic "pprComp" (pprQuals quals)
 
-pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body)
-         => [LStmt p body] -> SDoc
+pprQuals :: (OutputableBndrId (GhcPass p), Outputable body)
+         => [LStmt (GhcPass p) body] -> SDoc
 -- Show list comprehension qualifiers separated by commas
 pprQuals quals = interpp'SP quals
 
@@ -2068,30 +2376,40 @@ pprQuals quals = interpp'SP quals
 -- | Haskell Splice
 data HsSplice id
    = HsTypedSplice       --  $$z  or $$(f 4)
+        (XTypedSplice id)
         SpliceDecoration -- Whether $$( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsUntypedSplice     --  $z  or $(f 4)
+        (XUntypedSplice id)
         SpliceDecoration -- Whether $( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsQuasiQuote        -- See Note [Quasi-quote overview] in TcSplice
+        (XQuasiQuote id)
         (IdP id)         -- Splice point
         (IdP id)         -- Quoter
         SrcSpan          -- The span of the enclosed string
         FastString       -- The enclosed string
 
+   -- AZ:TODO: use XSplice instead of HsSpliced
    | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in
                 -- RnSplice.
                 -- This is the result of splicing a splice. It is produced by
                 -- the renamer and consumed by the typechecker. It lives only
                 -- between the two.
+        (XSpliced id)
         ThModFinalizers     -- TH finalizers produced by the splice.
         (HsSplicedThing id) -- The result of splicing
-  deriving Typeable
-deriving instance (DataId id) => Data (HsSplice id)
+   | XSplice (XXSplice id)  -- Note [Trees that Grow] extension point
+
+type instance XTypedSplice   (GhcPass _) = NoExt
+type instance XUntypedSplice (GhcPass _) = NoExt
+type instance XQuasiQuote    (GhcPass _) = NoExt
+type instance XSpliced       (GhcPass _) = NoExt
+type instance XXSplice       (GhcPass _) = NoExt
 
 -- | A splice can appear with various decorations wrapped around it. This data
 -- type captures explicitly how it was originally written, for use in the pretty
@@ -2131,18 +2449,14 @@ data HsSplicedThing id
     = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression
     | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type
     | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern
-  deriving Typeable
 
-deriving instance (DataId id) => Data (HsSplicedThing id)
 
 -- See Note [Pending Splices]
 type SplicePointName = Name
 
 -- | Pending Renamer Splice
 data PendingRnSplice
-  -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn?
   = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
-  deriving Data
 
 data UntypedSpliceFlavour
   = UntypedExpSplice
@@ -2153,10 +2467,8 @@ data UntypedSpliceFlavour
 
 -- | Pending Type-checker Splice
 data PendingTcSplice
-  -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc?
+  -- AZ:TODO: The hard-coded GhcTc feels wrong.
   = PendingTcSplice SplicePointName (LHsExpr GhcTc)
-  deriving Data
-
 
 {-
 Note [Pending Splices]
@@ -2222,85 +2534,99 @@ splices. In contrast, when pretty printing the output of the type checker, we
 sense, although I hate to add another constructor to HsExpr.
 -}
 
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsSplicedThing p) where
   ppr (HsSplicedExpr e) = ppr_expr e
   ppr (HsSplicedTy   t) = ppr t
   ppr (HsSplicedPat  p) = ppr p
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where
   ppr s = pprSplice s
 
-pprPendingSplice :: (SourceTextX p, OutputableBndrId p)
-                 => SplicePointName -> LHsExpr p -> SDoc
+pprPendingSplice :: (OutputableBndrId (GhcPass p))
+                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
 pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
 
-pprSpliceDecl ::  (SourceTextX p, OutputableBndrId p)
-          => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl ::  (OutputableBndrId (GhcPass p))
+          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
 pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
 pprSpliceDecl e ExplicitSplice   = text "$(" <> ppr_splice_decl e <> text ")"
 pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e
 
-ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl :: (OutputableBndrId (GhcPass p))
+                => HsSplice (GhcPass p) -> SDoc
+ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
 ppr_splice_decl e = pprSplice e
 
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
-pprSplice (HsTypedSplice HasParens  n e)
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
+pprSplice (HsTypedSplice _ HasParens  n e)
   = ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice HasDollar n e)
+pprSplice (HsTypedSplice _ HasDollar n e)
   = ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice NoParens n e)
+pprSplice (HsTypedSplice _ NoParens n e)
   = ppr_splice empty n e empty
-pprSplice (HsUntypedSplice HasParens  n e)
+pprSplice (HsUntypedSplice _ HasParens  n e)
   = ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice HasDollar n e)
+pprSplice (HsUntypedSplice _ HasDollar n e)
   = ppr_splice (text "$")  n e empty
-pprSplice (HsUntypedSplice NoParens n e)
+pprSplice (HsUntypedSplice _ NoParens n e)
   = ppr_splice empty  n e empty
-pprSplice (HsQuasiQuote n q _ s)      = ppr_quasi n q s
-pprSplice (HsSpliced _ thing)         = ppr thing
+pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s
+pprSplice (HsSpliced _ _ thing)         = ppr thing
+pprSplice (XSplice x)                   = ppr x
 
 ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
-ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
+ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
                            char '[' <> ppr quoter <> vbar <>
                            ppr quote <> text "|]"
 
-ppr_splice :: (SourceTextX p, OutputableBndrId p)
-           => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc
+ppr_splice :: (OutputableBndrId (GhcPass p))
+           => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
 ppr_splice herald n e trail
-    = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail
+    = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
 
 -- | Haskell Bracket
-data HsBracket p = ExpBr (LHsExpr p)    -- [|  expr  |]
-                  | PatBr (LPat p)      -- [p| pat   |]
-                  | DecBrL [LHsDecl p]  -- [d| decls |]; result of parser
-                  | DecBrG (HsGroup p)  -- [d| decls |]; result of renamer
-                  | TypBr (LHsType p)   -- [t| type  |]
-                  | VarBr Bool (IdP p)  -- True: 'x, False: ''T
-                                 -- (The Bool flag is used only in pprHsBracket)
-                  | TExpBr (LHsExpr p)  -- [||  expr  ||]
-deriving instance (DataId p) => Data (HsBracket p)
+data HsBracket p
+  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]
+  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]
+  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser
+  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer
+  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]
+  | VarBr  (XVarBr p)   Bool (IdP p)  -- True: 'x, False: ''T
+                                -- (The Bool flag is used only in pprHsBracket)
+  | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]
+  | XBracket (XXBracket p)            -- Note [Trees that Grow] extension point
+
+type instance XExpBr      (GhcPass _) = NoExt
+type instance XPatBr      (GhcPass _) = NoExt
+type instance XDecBrL     (GhcPass _) = NoExt
+type instance XDecBrG     (GhcPass _) = NoExt
+type instance XTypBr      (GhcPass _) = NoExt
+type instance XVarBr      (GhcPass _) = NoExt
+type instance XTExpBr     (GhcPass _) = NoExt
+type instance XXBracket   (GhcPass _) = NoExt
 
 isTypedBracket :: HsBracket id -> Bool
 isTypedBracket (TExpBr {}) = True
 isTypedBracket _           = False
 
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+          => Outputable (HsBracket p) where
   ppr = pprHsBracket
 
 
-pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc
-pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
-pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc
+pprHsBracket (ExpBr _ e)   = thBrackets empty (ppr e)
+pprHsBracket (PatBr _ p)   = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr _ t)   = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr _ True n)
   = char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr _ False n)
   = text "''" <> pprPrefixOcc n
-pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
+pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)
+pprHsBracket (XBracket e)  = ppr e
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -2333,9 +2659,9 @@ data ArithSeqInfo id
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
-deriving instance (DataId id) => Data (ArithSeqInfo id)
+-- AZ: Sould ArithSeqInfo have a TTG extension?
 
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
          => Outputable (ArithSeqInfo p) where
     ppr (From e1)             = hcat [ppr e1, pp_dotdot]
     ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
@@ -2359,11 +2685,10 @@ pp_dotdot = text " .. "
 -- Context of a pattern match. This is more subtle than it would seem. See Note
 -- [Varieties of pattern matches].
 data HsMatchContext id -- Not an extensible tag
-  = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
-           , mc_fixity :: LexicalFixity -- ^ fixing of @f@
-           , mc_strictness :: SrcStrictness
-             -- ^ was the pattern banged? See
-             -- Note [Varieties of binding pattern matches]
+  = FunRhs { mc_fun        :: Located id    -- ^ function binder of @f@
+           , mc_fixity     :: LexicalFixity -- ^ fixing of @f@
+           , mc_strictness :: SrcStrictness -- ^ was @f@ banged?
+                                            -- See Note [FunBind vs PatBind]
            }
                                 -- ^A pattern matching on an argument of a
                                 -- function binding
@@ -2372,6 +2697,9 @@ data HsMatchContext id -- Not an extensible tag
   | IfAlt                       -- ^Guards of a multi-way if alternative
   | ProcExpr                    -- ^Patterns of a proc
   | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e
+  | PatBindGuards               -- ^Guards of pattern bindings, e.g.,
+                                --    (Just b) | Just _ <- x = e
+                                --             | otherwise   = e'
 
   | RecUpd                      -- ^Record update [used only in DsExpr to
                                 --    tell matchWrapper what sort of
@@ -2393,6 +2721,7 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where
   ppr IfAlt                 = text "IfAlt"
   ppr ProcExpr              = text "ProcExpr"
   ppr PatBindRhs            = text "PatBindRhs"
+  ppr PatBindGuards         = text "PatBindGuards"
   ppr RecUpd                = text "RecUpd"
   ppr (StmtCtxt _)          = text "StmtCtxt _"
   ppr ThPatSplice           = text "ThPatSplice"
@@ -2410,7 +2739,6 @@ isPatSynCtxt ctxt =
 data HsStmtContext id
   = ListComp
   | MonadComp
-  | PArrComp                         -- ^Parallel array comprehension
 
   | DoExpr                           -- ^do { ... }
   | MDoExpr                          -- ^mdo { ... }  ie recursive do-expression
@@ -2423,39 +2751,39 @@ data HsStmtContext id
   deriving Functor
 deriving instance (Data id) => Data (HsStmtContext id)
 
-isListCompExpr :: HsStmtContext id -> Bool
--- Uses syntax [ e | quals ]
-isListCompExpr ListComp          = True
-isListCompExpr PArrComp          = True
-isListCompExpr MonadComp         = True
-isListCompExpr (ParStmtCtxt c)   = isListCompExpr c
-isListCompExpr (TransStmtCtxt c) = isListCompExpr c
-isListCompExpr _                 = False
-
-isMonadCompExpr :: HsStmtContext id -> Bool
-isMonadCompExpr MonadComp            = True
-isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
-isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
-isMonadCompExpr _                    = False
+isComprehensionContext :: HsStmtContext id -> Bool
+-- Uses comprehension syntax [ e | quals ]
+isComprehensionContext ListComp          = True
+isComprehensionContext MonadComp         = True
+isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c
+isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
+isComprehensionContext _ = False
 
 -- | Should pattern match failure in a 'HsStmtContext' be desugared using
 -- 'MonadFail'?
 isMonadFailStmtContext :: HsStmtContext id -> Bool
-isMonadFailStmtContext MonadComp    = True
-isMonadFailStmtContext DoExpr       = True
-isMonadFailStmtContext MDoExpr      = True
-isMonadFailStmtContext GhciStmtCtxt = True
-isMonadFailStmtContext _            = False
+isMonadFailStmtContext MonadComp            = True
+isMonadFailStmtContext DoExpr               = True
+isMonadFailStmtContext MDoExpr              = True
+isMonadFailStmtContext GhciStmtCtxt         = True
+isMonadFailStmtContext (ParStmtCtxt ctxt)   = isMonadFailStmtContext ctxt
+isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
+isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+
+isMonadCompContext :: HsStmtContext id -> Bool
+isMonadCompContext MonadComp = True
+isMonadCompContext _         = False
 
 matchSeparator :: HsMatchContext id -> SDoc
-matchSeparator (FunRhs {})  = text "="
-matchSeparator CaseAlt      = text "->"
-matchSeparator IfAlt        = text "->"
-matchSeparator LambdaExpr   = text "->"
-matchSeparator ProcExpr     = text "->"
-matchSeparator PatBindRhs   = text "="
-matchSeparator (StmtCtxt _) = text "<-"
-matchSeparator RecUpd       = text "=" -- This can be printed by the pattern
+matchSeparator (FunRhs {})   = text "="
+matchSeparator CaseAlt       = text "->"
+matchSeparator IfAlt         = text "->"
+matchSeparator LambdaExpr    = text "->"
+matchSeparator ProcExpr      = text "->"
+matchSeparator PatBindRhs    = text "="
+matchSeparator PatBindGuards = text "="
+matchSeparator (StmtCtxt _)  = text "<-"
+matchSeparator RecUpd        = text "=" -- This can be printed by the pattern
                                        -- match checker trace
 matchSeparator ThPatSplice  = panic "unused"
 matchSeparator ThPatQuote   = panic "unused"
@@ -2482,10 +2810,11 @@ pprMatchContextNoun RecUpd          = text "record-update construct"
 pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"
 pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"
 pprMatchContextNoun PatBindRhs      = text "pattern binding"
+pprMatchContextNoun PatBindGuards   = text "pattern binding guards"
 pprMatchContextNoun LambdaExpr      = text "lambda abstraction"
 pprMatchContextNoun ProcExpr        = text "arrow abstraction"
 pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
-                                      $$ pprStmtContext ctxt
+                                      $$ pprAStmtContext ctxt
 pprMatchContextNoun PatSyn          = text "pattern synonym declaration"
 
 -----------------
@@ -2498,7 +2827,6 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
     pp_a  = text "a"
     article = case ctxt of
                   MDoExpr       -> pp_an
-                  PArrComp      -> pp_an
                   GhciStmtCtxt  -> pp_an
                   _             -> pp_a
 
@@ -2510,7 +2838,6 @@ pprStmtContext MDoExpr         = text "'mdo' block"
 pprStmtContext ArrowExpr       = text "'do' block in an arrow command"
 pprStmtContext ListComp        = text "list comprehension"
 pprStmtContext MonadComp       = text "monad comprehension"
-pprStmtContext PArrComp        = text "array comprehension"
 pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
 
 -- Drop the inner contexts when reporting errors, else we get
@@ -2519,13 +2846,11 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx
 --          transformed branch of
 --          transformed branch of monad comprehension
 pprStmtContext (ParStmtCtxt c) =
-  sdocWithPprDebug $ \dbg -> if dbg
-    then sep [text "parallel branch of", pprAStmtContext c]
-    else pprStmtContext c
+  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])
+             (pprStmtContext c)
 pprStmtContext (TransStmtCtxt c) =
-  sdocWithPprDebug $ \dbg -> if dbg
-    then sep [text "transformed branch of", pprAStmtContext c]
-    else pprStmtContext c
+  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
+             (pprStmtContext c)
 
 instance (Outputable p, Outputable (NameOrRdrName p))
       => Outputable (HsStmtContext p) where
@@ -2538,6 +2863,7 @@ matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun
 matchContextErrString CaseAlt                    = text "case"
 matchContextErrString IfAlt                      = text "multi-way if"
 matchContextErrString PatBindRhs                 = text "pattern binding"
+matchContextErrString PatBindGuards              = text "pattern binding guards"
 matchContextErrString RecUpd                     = text "record update"
 matchContextErrString LambdaExpr                 = text "lambda"
 matchContextErrString ProcExpr                   = text "proc"
@@ -2553,23 +2879,24 @@ matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"
 matchContextErrString (StmtCtxt MDoExpr)           = text "'mdo' block"
 matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"
 matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"
-matchContextErrString (StmtCtxt PArrComp)          = text "array comprehension"
 
-pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR,
+pprMatchInCtxt :: (OutputableBndrId (GhcPass idR),
                    -- TODO:AZ these constraints do not make sense
-                   Outputable (NameOrRdrName (NameOrRdrName (IdP idR))),
-                   Outputable body)
-               => Match idR body -> SDoc
+                 Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
+                 Outputable body)
+               => Match (GhcPass idR) body -> SDoc
 pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)
                                         <> colon)
                              4 (pprMatch match)
 
-pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR,
-                  OutputableBndrId idL, OutputableBndrId idR,
+pprStmtInCtxt :: (OutputableBndrId (GhcPass idL),
+                  OutputableBndrId (GhcPass idR),
                   Outputable body)
-               => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc
-pprStmtInCtxt ctxt (LastStmt e _ _)
-  | isListCompExpr ctxt      -- For [ e | .. ], do not mutter about "stmts"
+              => HsStmtContext (IdP (GhcPass idL))
+              -> StmtLR (GhcPass idL) (GhcPass idR) body
+              -> SDoc
+pprStmtInCtxt ctxt (LastStmt _ e _ _)
+  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"
   = hang (text "In the expression:") 2 (ppr e)
 
 pprStmtInCtxt ctxt stmt
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index bac8a5a183..109e9814e5 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -5,6 +5,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsExpr where
 
@@ -12,13 +13,12 @@ import SrcLoc     ( Located )
 import Outputable ( SDoc, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
 import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, SourceTextX )
-import Data.Data hiding ( Fixity )
+import HsExtension ( OutputableBndrId, GhcPass )
 
 type role HsExpr nominal
 type role HsCmd nominal
-type role MatchGroup nominal representational
-type role GRHSs nominal representational
+type role MatchGroup nominal nominal
+type role GRHSs nominal nominal
 type role HsSplice nominal
 type role SyntaxExpr nominal
 data HsExpr (i :: *)
@@ -28,32 +28,24 @@ data MatchGroup (a :: *) (body :: *)
 data GRHSs (a :: *) (body :: *)
 data SyntaxExpr (i :: *)
 
-instance (DataId p) => Data (HsSplice p)
-instance (DataId p) => Data (HsExpr p)
-instance (DataId p) => Data (HsCmd p)
-instance (Data body,DataId p) => Data (MatchGroup p body)
-instance (Data body,DataId p) => Data (GRHSs p body)
-instance (DataId p) => Data (SyntaxExpr p)
-
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
 
 type LHsExpr a = Located (HsExpr a)
 
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
 
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
 
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
 
-pprSpliceDecl ::  (SourceTextX p, OutputableBndrId p)
-          => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl ::  (OutputableBndrId (GhcPass p))
+          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
 
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
-                                   OutputableBndrId bndr,
-                                   OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+                                   OutputableBndrId (GhcPass p),
                                    Outputable body)
-           => LPat bndr -> GRHSs p body -> SDoc
+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
 
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
-           => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+           => MatchGroup (GhcPass idR) body -> SDoc
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 880f7096c6..a7c467dce4 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -7,26 +7,25 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
 
 module HsExtension where
 
 -- This module captures the type families to precisely identify the extension
 -- points for HsSyn
 
+import GhcPrelude
+
 import GHC.Exts (Constraint)
 import Data.Data hiding ( Fixity )
 import PlaceHolder
-import BasicTypes
-import ConLike
-import NameSet
 import Name
 import RdrName
 import Var
-import Type       ( Type )
 import Outputable
 import SrcLoc (Located)
-import Coercion
-import TcEvidence
 
 {-
 Note [Trees that grow]
@@ -53,6 +52,17 @@ haskell-src-exts ASTs as well.
 
 -}
 
+-- | used as place holder in TTG values
+data NoExt = NoExt
+  deriving (Data,Eq,Ord)
+
+instance Outputable NoExt where
+  ppr _ = text "NoExt"
+
+-- | Used when constructing a term with an unused extension point.
+noExt :: NoExt
+noExt = NoExt
+
 -- | Used as a data type index for the hsSyn AST
 data GhcPass (c :: Pass)
 deriving instance Eq (GhcPass c)
@@ -67,25 +77,707 @@ type GhcRn   = GhcPass 'Renamed     -- Old 'Name' type param
 type GhcTc   = GhcPass 'Typechecked -- Old 'Id' type para,
 type GhcTcId = GhcTc                -- Old 'TcId' type param
 
-
--- | Types that are not defined until after type checking
-type family PostTc x ty -- Note [Pass sensitive types] in PlaceHolder
-type instance PostTc GhcPs ty = PlaceHolder
-type instance PostTc GhcRn ty = PlaceHolder
-type instance PostTc GhcTc ty = ty
-
--- | Types that are not defined until after renaming
-type family PostRn x ty  -- Note [Pass sensitive types] in PlaceHolder
-type instance PostRn GhcPs ty = PlaceHolder
-type instance PostRn GhcRn ty = ty
-type instance PostRn GhcTc ty = ty
-
 -- | Maps the "normal" id type for a given pass
 type family IdP p
 type instance IdP GhcPs = RdrName
 type instance IdP GhcRn = Name
 type instance IdP GhcTc = Id
 
+type LIdP p = Located (IdP p)
+
+-- =====================================================================
+-- Type families for the HsBinds extension points
+
+-- HsLocalBindsLR type families
+type family XHsValBinds      x x'
+type family XHsIPBinds       x x'
+type family XEmptyLocalBinds x x'
+type family XXHsLocalBindsLR x x'
+
+type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XHsValBinds      x x')
+       , c (XHsIPBinds       x x')
+       , c (XEmptyLocalBinds x x')
+       , c (XXHsLocalBindsLR x x')
+       )
+
+-- ValBindsLR type families
+type family XValBinds    x x'
+type family XXValBindsLR x x'
+
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XValBinds    x x')
+       , c (XXValBindsLR x x')
+       )
+
+
+-- HsBindsLR type families
+type family XFunBind    x x'
+type family XPatBind    x x'
+type family XVarBind    x x'
+type family XAbsBinds   x x'
+type family XPatSynBind x x'
+type family XXHsBindsLR x x'
+
+type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XFunBind    x x')
+       , c (XPatBind    x x')
+       , c (XVarBind    x x')
+       , c (XAbsBinds   x x')
+       , c (XPatSynBind x x')
+       , c (XXHsBindsLR x x')
+       )
+
+-- ABExport type families
+type family XABE x
+type family XXABExport x
+
+type ForallXABExport (c :: * -> Constraint) (x :: *) =
+       ( c (XABE       x)
+       , c (XXABExport x)
+       )
+
+-- PatSynBind type families
+type family XPSB x x'
+type family XXPatSynBind x x'
+
+type ForallXPatSynBind  (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XPSB         x x')
+       , c (XXPatSynBind x x')
+       )
+
+-- HsIPBinds type families
+type family XIPBinds    x
+type family XXHsIPBinds x
+
+type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
+       ( c (XIPBinds    x)
+       , c (XXHsIPBinds x)
+       )
+
+-- IPBind type families
+type family XCIPBind x
+type family XXIPBind x
+
+type ForallXIPBind (c :: * -> Constraint) (x :: *) =
+       ( c (XCIPBind x)
+       , c (XXIPBind x)
+       )
+
+-- Sig type families
+type family XTypeSig          x
+type family XPatSynSig        x
+type family XClassOpSig       x
+type family XIdSig            x
+type family XFixSig           x
+type family XInlineSig        x
+type family XSpecSig          x
+type family XSpecInstSig      x
+type family XMinimalSig       x
+type family XSCCFunSig        x
+type family XCompleteMatchSig x
+type family XXSig             x
+
+type ForallXSig (c :: * -> Constraint) (x :: *) =
+       ( c (XTypeSig          x)
+       , c (XPatSynSig        x)
+       , c (XClassOpSig       x)
+       , c (XIdSig            x)
+       , c (XFixSig           x)
+       , c (XInlineSig        x)
+       , c (XSpecSig          x)
+       , c (XSpecInstSig      x)
+       , c (XMinimalSig       x)
+       , c (XSCCFunSig        x)
+       , c (XCompleteMatchSig x)
+       , c (XXSig             x)
+       )
+
+-- FixitySig type families
+type family XFixitySig          x
+type family XXFixitySig         x
+
+type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
+       ( c (XFixitySig         x)
+       , c (XXFixitySig        x)
+       )
+
+-- =====================================================================
+-- Type families for the HsDecls extension points
+
+-- HsDecl type families
+type family XTyClD       x
+type family XInstD       x
+type family XDerivD      x
+type family XValD        x
+type family XSigD        x
+type family XDefD        x
+type family XForD        x
+type family XWarningD    x
+type family XAnnD        x
+type family XRuleD       x
+type family XSpliceD     x
+type family XDocD        x
+type family XRoleAnnotD  x
+type family XXHsDecl     x
+
+type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XTyClD       x)
+       , c (XInstD       x)
+       , c (XDerivD      x)
+       , c (XValD        x)
+       , c (XSigD        x)
+       , c (XDefD        x)
+       , c (XForD        x)
+       , c (XWarningD    x)
+       , c (XAnnD        x)
+       , c (XRuleD       x)
+       , c (XSpliceD     x)
+       , c (XDocD        x)
+       , c (XRoleAnnotD  x)
+       , c (XXHsDecl    x)
+       )
+
+-- -------------------------------------
+-- HsGroup type families
+type family XCHsGroup      x
+type family XXHsGroup      x
+
+type ForallXHsGroup (c :: * -> Constraint) (x :: *) =
+       ( c (XCHsGroup       x)
+       , c (XXHsGroup       x)
+       )
+
+-- -------------------------------------
+-- SpliceDecl type families
+type family XSpliceDecl       x
+type family XXSpliceDecl      x
+
+type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XSpliceDecl        x)
+       , c (XXSpliceDecl       x)
+       )
+
+-- -------------------------------------
+-- TyClDecl type families
+type family XFamDecl       x
+type family XSynDecl       x
+type family XDataDecl      x
+type family XClassDecl     x
+type family XXTyClDecl     x
+
+type ForallXTyClDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XFamDecl       x)
+       , c (XSynDecl       x)
+       , c (XDataDecl      x)
+       , c (XClassDecl     x)
+       , c (XXTyClDecl     x)
+       )
+
+-- -------------------------------------
+-- TyClGroup type families
+type family XCTyClGroup      x
+type family XXTyClGroup      x
+
+type ForallXTyClGroup (c :: * -> Constraint) (x :: *) =
+       ( c (XCTyClGroup       x)
+       , c (XXTyClGroup       x)
+       )
+
+-- -------------------------------------
+-- FamilyResultSig type families
+type family XNoSig            x
+type family XCKindSig         x -- Clashes with XKindSig above
+type family XTyVarSig         x
+type family XXFamilyResultSig x
+
+type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) =
+       ( c (XNoSig            x)
+       , c (XCKindSig         x)
+       , c (XTyVarSig         x)
+       , c (XXFamilyResultSig x)
+       )
+
+-- -------------------------------------
+-- FamilyDecl type families
+type family XCFamilyDecl      x
+type family XXFamilyDecl      x
+
+type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCFamilyDecl       x)
+       , c (XXFamilyDecl       x)
+       )
+
+-- -------------------------------------
+-- HsDataDefn type families
+type family XCHsDataDefn      x
+type family XXHsDataDefn      x
+
+type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) =
+       ( c (XCHsDataDefn       x)
+       , c (XXHsDataDefn       x)
+       )
+
+-- -------------------------------------
+-- HsDerivingClause type families
+type family XCHsDerivingClause      x
+type family XXHsDerivingClause      x
+
+type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) =
+       ( c (XCHsDerivingClause       x)
+       , c (XXHsDerivingClause       x)
+       )
+
+-- -------------------------------------
+-- ConDecl type families
+type family XConDeclGADT   x
+type family XConDeclH98    x
+type family XXConDecl      x
+
+type ForallXConDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XConDeclGADT    x)
+       , c (XConDeclH98     x)
+       , c (XXConDecl       x)
+       )
+
+-- -------------------------------------
+-- FamEqn type families
+type family XCFamEqn      x p r
+type family XXFamEqn      x p r
+
+type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) =
+       ( c (XCFamEqn       x p r)
+       , c (XXFamEqn       x p r)
+       )
+
+-- -------------------------------------
+-- ClsInstDecl type families
+type family XCClsInstDecl      x
+type family XXClsInstDecl      x
+
+type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCClsInstDecl       x)
+       , c (XXClsInstDecl       x)
+       )
+
+-- -------------------------------------
+-- ClsInstDecl type families
+type family XClsInstD      x
+type family XDataFamInstD  x
+type family XTyFamInstD    x
+type family XXInstDecl     x
+
+type ForallXInstDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XClsInstD       x)
+       , c (XDataFamInstD   x)
+       , c (XTyFamInstD     x)
+       , c (XXInstDecl      x)
+       )
+
+-- -------------------------------------
+-- DerivDecl type families
+type family XCDerivDecl      x
+type family XXDerivDecl      x
+
+type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCDerivDecl       x)
+       , c (XXDerivDecl       x)
+       )
+
+-- -------------------------------------
+-- DerivStrategy type family
+type family XViaStrategy x
+
+-- -------------------------------------
+-- DefaultDecl type families
+type family XCDefaultDecl      x
+type family XXDefaultDecl      x
+
+type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCDefaultDecl       x)
+       , c (XXDefaultDecl       x)
+       )
+
+-- -------------------------------------
+-- DefaultDecl type families
+type family XForeignImport     x
+type family XForeignExport     x
+type family XXForeignDecl      x
+
+type ForallXForeignDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XForeignImport      x)
+       , c (XForeignExport      x)
+       , c (XXForeignDecl       x)
+       )
+
+-- -------------------------------------
+-- RuleDecls type families
+type family XCRuleDecls      x
+type family XXRuleDecls      x
+
+type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
+       ( c (XCRuleDecls       x)
+       , c (XXRuleDecls       x)
+       )
+
+
+-- -------------------------------------
+-- RuleDecl type families
+type family XHsRule         x
+type family XXRuleDecl      x
+
+type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XHsRule          x)
+       , c (XXRuleDecl       x)
+       )
+
+-- -------------------------------------
+-- RuleBndr type families
+type family XCRuleBndr      x
+type family XRuleBndrSig    x
+type family XXRuleBndr      x
+
+type ForallXRuleBndr (c :: * -> Constraint) (x :: *) =
+       ( c (XCRuleBndr       x)
+       , c (XRuleBndrSig     x)
+       , c (XXRuleBndr       x)
+       )
+
+-- -------------------------------------
+-- WarnDecls type families
+type family XWarnings        x
+type family XXWarnDecls      x
+
+type ForallXWarnDecls (c :: * -> Constraint) (x :: *) =
+       ( c (XWarnings        x)
+       , c (XXWarnDecls      x)
+       )
+
+-- -------------------------------------
+-- AnnDecl type families
+type family XWarning        x
+type family XXWarnDecl      x
+
+type ForallXWarnDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XWarning        x)
+       , c (XXWarnDecl      x)
+       )
+
+-- -------------------------------------
+-- AnnDecl type families
+type family XHsAnnotation  x
+type family XXAnnDecl      x
+
+type ForallXAnnDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XHsAnnotation  x)
+       , c (XXAnnDecl      x)
+       )
+
+-- -------------------------------------
+-- RoleAnnotDecl type families
+type family XCRoleAnnotDecl  x
+type family XXRoleAnnotDecl  x
+
+type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCRoleAnnotDecl  x)
+       , c (XXRoleAnnotDecl  x)
+       )
+
+-- =====================================================================
+-- Type families for the HsExpr extension points
+
+type family XVar            x
+type family XUnboundVar     x
+type family XConLikeOut     x
+type family XRecFld         x
+type family XOverLabel      x
+type family XIPVar          x
+type family XOverLitE       x
+type family XLitE           x
+type family XLam            x
+type family XLamCase        x
+type family XApp            x
+type family XAppTypeE       x
+type family XOpApp          x
+type family XNegApp         x
+type family XPar            x
+type family XSectionL       x
+type family XSectionR       x
+type family XExplicitTuple  x
+type family XExplicitSum    x
+type family XCase           x
+type family XIf             x
+type family XMultiIf        x
+type family XLet            x
+type family XDo             x
+type family XExplicitList   x
+type family XRecordCon      x
+type family XRecordUpd      x
+type family XExprWithTySig  x
+type family XArithSeq       x
+type family XSCC            x
+type family XCoreAnn        x
+type family XBracket        x
+type family XRnBracketOut   x
+type family XTcBracketOut   x
+type family XSpliceE        x
+type family XProc           x
+type family XStatic         x
+type family XArrApp         x
+type family XArrForm        x
+type family XTick           x
+type family XBinTick        x
+type family XTickPragma     x
+type family XEWildPat       x
+type family XEAsPat         x
+type family XEViewPat       x
+type family XELazyPat       x
+type family XWrap           x
+type family XXExpr          x
+
+type ForallXExpr (c :: * -> Constraint) (x :: *) =
+       ( c (XVar            x)
+       , c (XUnboundVar     x)
+       , c (XConLikeOut     x)
+       , c (XRecFld         x)
+       , c (XOverLabel      x)
+       , c (XIPVar          x)
+       , c (XOverLitE       x)
+       , c (XLitE           x)
+       , c (XLam            x)
+       , c (XLamCase        x)
+       , c (XApp            x)
+       , c (XAppTypeE       x)
+       , c (XOpApp          x)
+       , c (XNegApp         x)
+       , c (XPar            x)
+       , c (XSectionL       x)
+       , c (XSectionR       x)
+       , c (XExplicitTuple  x)
+       , c (XExplicitSum    x)
+       , c (XCase           x)
+       , c (XIf             x)
+       , c (XMultiIf        x)
+       , c (XLet            x)
+       , c (XDo             x)
+       , c (XExplicitList   x)
+       , c (XRecordCon      x)
+       , c (XRecordUpd      x)
+       , c (XExprWithTySig  x)
+       , c (XArithSeq       x)
+       , c (XSCC            x)
+       , c (XCoreAnn        x)
+       , c (XBracket        x)
+       , c (XRnBracketOut   x)
+       , c (XTcBracketOut   x)
+       , c (XSpliceE        x)
+       , c (XProc           x)
+       , c (XStatic         x)
+       , c (XArrApp         x)
+       , c (XArrForm        x)
+       , c (XTick           x)
+       , c (XBinTick        x)
+       , c (XTickPragma     x)
+       , c (XEWildPat       x)
+       , c (XEAsPat         x)
+       , c (XEViewPat       x)
+       , c (XELazyPat       x)
+       , c (XWrap           x)
+       , c (XXExpr          x)
+       )
+-- ---------------------------------------------------------------------
+
+type family XUnambiguous        x
+type family XAmbiguous          x
+type family XXAmbiguousFieldOcc x
+
+type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
+       ( c (XUnambiguous        x)
+       , c (XAmbiguous          x)
+       , c (XXAmbiguousFieldOcc x)
+       )
+
+-- ----------------------------------------------------------------------
+
+type family XPresent  x
+type family XMissing  x
+type family XXTupArg  x
+
+type ForallXTupArg (c :: * -> Constraint) (x :: *) =
+       ( c (XPresent x)
+       , c (XMissing x)
+       , c (XXTupArg x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XTypedSplice   x
+type family XUntypedSplice x
+type family XQuasiQuote    x
+type family XSpliced       x
+type family XXSplice       x
+
+type ForallXSplice (c :: * -> Constraint) (x :: *) =
+       ( c (XTypedSplice   x)
+       , c (XUntypedSplice x)
+       , c (XQuasiQuote    x)
+       , c (XSpliced       x)
+       , c (XXSplice       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XExpBr      x
+type family XPatBr      x
+type family XDecBrL     x
+type family XDecBrG     x
+type family XTypBr      x
+type family XVarBr      x
+type family XTExpBr     x
+type family XXBracket   x
+
+type ForallXBracket (c :: * -> Constraint) (x :: *) =
+       ( c (XExpBr      x)
+       , c (XPatBr      x)
+       , c (XDecBrL     x)
+       , c (XDecBrG     x)
+       , c (XTypBr      x)
+       , c (XVarBr      x)
+       , c (XTExpBr     x)
+       , c (XXBracket   x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdTop  x
+type family XXCmdTop x
+
+type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdTop  x)
+       , c (XXCmdTop x)
+       )
+
+-- -------------------------------------
+
+type family XMG           x b
+type family XXMatchGroup  x b
+
+type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XMG          x b)
+       , c (XXMatchGroup x b)
+       )
+
+-- -------------------------------------
+
+type family XCMatch  x b
+type family XXMatch  x b
+
+type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XCMatch  x b)
+       , c (XXMatch  x b)
+       )
+
+-- -------------------------------------
+
+type family XCGRHSs  x b
+type family XXGRHSs  x b
+
+type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XCGRHSs  x b)
+       , c (XXGRHSs  x b)
+       )
+
+-- -------------------------------------
+
+type family XCGRHS  x b
+type family XXGRHS  x b
+
+type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XCGRHS  x b)
+       , c (XXGRHS  x b)
+       )
+
+-- -------------------------------------
+
+type family XLastStmt        x x' b
+type family XBindStmt        x x' b
+type family XApplicativeStmt x x' b
+type family XBodyStmt        x x' b
+type family XLetStmt         x x' b
+type family XParStmt         x x' b
+type family XTransStmt       x x' b
+type family XRecStmt         x x' b
+type family XXStmtLR         x x' b
+
+type ForallXStmtLR (c :: * -> Constraint) (x :: *)  (x' :: *) (b :: *) =
+       ( c (XLastStmt         x x' b)
+       , c (XBindStmt         x x' b)
+       , c (XApplicativeStmt  x x' b)
+       , c (XBodyStmt         x x' b)
+       , c (XLetStmt          x x' b)
+       , c (XParStmt          x x' b)
+       , c (XTransStmt        x x' b)
+       , c (XRecStmt          x x' b)
+       , c (XXStmtLR          x x' b)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdArrApp  x
+type family XCmdArrForm x
+type family XCmdApp     x
+type family XCmdLam     x
+type family XCmdPar     x
+type family XCmdCase    x
+type family XCmdIf      x
+type family XCmdLet     x
+type family XCmdDo      x
+type family XCmdWrap    x
+type family XXCmd       x
+
+type ForallXCmd (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdArrApp  x)
+       , c (XCmdArrForm x)
+       , c (XCmdApp     x)
+       , c (XCmdLam     x)
+       , c (XCmdPar     x)
+       , c (XCmdCase    x)
+       , c (XCmdIf      x)
+       , c (XCmdLet     x)
+       , c (XCmdDo      x)
+       , c (XCmdWrap    x)
+       , c (XXCmd       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XParStmtBlock  x x'
+type family XXParStmtBlock x x'
+
+type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XParStmtBlock  x x')
+       , c (XXParStmtBlock x x')
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XApplicativeArgOne   x
+type family XApplicativeArgMany  x
+type family XXApplicativeArg     x
+
+type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) =
+       ( c (XApplicativeArgOne   x)
+       , c (XApplicativeArgMany  x)
+       , c (XXApplicativeArg     x)
+       )
+
+-- =====================================================================
+-- Type families for the HsImpExp extension points
+
+-- TODO
+
+-- =====================================================================
+-- Type families for the HsLit extension points
 
 -- We define a type family for each extension point. This is based on prepending
 -- 'X' to the constructor name, for ease of reference.
@@ -102,128 +794,235 @@ type family XHsInteger x
 type family XHsRat x
 type family XHsFloatPrim x
 type family XHsDoublePrim x
+type family XXLit x
 
 -- | Helper to apply a constraint to all extension points. It has one
 -- entry per extension point type family.
-type ForallX (c :: * -> Constraint) (x :: *) =
-  ( c (XHsChar x)
-  , c (XHsCharPrim x)
-  , c (XHsString x)
+type ForallXHsLit (c :: * -> Constraint) (x :: *) =
+  ( c (XHsChar       x)
+  , c (XHsCharPrim   x)
+  , c (XHsDoublePrim x)
+  , c (XHsFloatPrim  x)
+  , c (XHsInt        x)
+  , c (XHsInt64Prim  x)
+  , c (XHsIntPrim    x)
+  , c (XHsInteger    x)
+  , c (XHsRat        x)
+  , c (XHsString     x)
   , c (XHsStringPrim x)
-  , c (XHsInt x)
-  , c (XHsIntPrim x)
-  , c (XHsWordPrim x)
-  , c (XHsInt64Prim x)
   , c (XHsWord64Prim x)
-  , c (XHsInteger x)
-  , c (XHsRat x)
-  , c (XHsFloatPrim x)
-  , c (XHsDoublePrim x)
+  , c (XHsWordPrim   x)
+  , c (XXLit         x)
   )
 
+type family XOverLit  x
+type family XXOverLit x
+
+type ForallXOverLit (c :: * -> Constraint) (x :: *) =
+       ( c (XOverLit  x)
+       , c (XXOverLit x)
+       )
+
+-- =====================================================================
+-- Type families for the HsPat extension points
 
--- Provide the specific extension types for the parser phase.
-type instance XHsChar       GhcPs = SourceText
-type instance XHsCharPrim   GhcPs = SourceText
-type instance XHsString     GhcPs = SourceText
-type instance XHsStringPrim GhcPs = SourceText
-type instance XHsInt        GhcPs = ()
-type instance XHsIntPrim    GhcPs = SourceText
-type instance XHsWordPrim   GhcPs = SourceText
-type instance XHsInt64Prim  GhcPs = SourceText
-type instance XHsWord64Prim GhcPs = SourceText
-type instance XHsInteger    GhcPs = SourceText
-type instance XHsRat        GhcPs = ()
-type instance XHsFloatPrim  GhcPs = ()
-type instance XHsDoublePrim GhcPs = ()
-
--- Provide the specific extension types for the renamer phase.
-type instance XHsChar       GhcRn = SourceText
-type instance XHsCharPrim   GhcRn = SourceText
-type instance XHsString     GhcRn = SourceText
-type instance XHsStringPrim GhcRn = SourceText
-type instance XHsInt        GhcRn = ()
-type instance XHsIntPrim    GhcRn = SourceText
-type instance XHsWordPrim   GhcRn = SourceText
-type instance XHsInt64Prim  GhcRn = SourceText
-type instance XHsWord64Prim GhcRn = SourceText
-type instance XHsInteger    GhcRn = SourceText
-type instance XHsRat        GhcRn = ()
-type instance XHsFloatPrim  GhcRn = ()
-type instance XHsDoublePrim GhcRn = ()
-
--- Provide the specific extension types for the typechecker phase.
-type instance XHsChar       GhcTc = SourceText
-type instance XHsCharPrim   GhcTc = SourceText
-type instance XHsString     GhcTc = SourceText
-type instance XHsStringPrim GhcTc = SourceText
-type instance XHsInt        GhcTc = ()
-type instance XHsIntPrim    GhcTc = SourceText
-type instance XHsWordPrim   GhcTc = SourceText
-type instance XHsInt64Prim  GhcTc = SourceText
-type instance XHsWord64Prim GhcTc = SourceText
-type instance XHsInteger    GhcTc = SourceText
-type instance XHsRat        GhcTc = ()
-type instance XHsFloatPrim  GhcTc = ()
-type instance XHsDoublePrim GhcTc = ()
+type family XWildPat   x
+type family XVarPat    x
+type family XLazyPat   x
+type family XAsPat     x
+type family XParPat    x
+type family XBangPat   x
+type family XListPat   x
+type family XTuplePat  x
+type family XSumPat    x
+type family XConPat    x
+type family XViewPat   x
+type family XSplicePat x
+type family XLitPat    x
+type family XNPat      x
+type family XNPlusKPat x
+type family XSigPat    x
+type family XCoPat     x
+type family XXPat      x
 
 
+type ForallXPat (c :: * -> Constraint) (x :: *) =
+       ( c (XWildPat   x)
+       , c (XVarPat    x)
+       , c (XLazyPat   x)
+       , c (XAsPat     x)
+       , c (XParPat    x)
+       , c (XBangPat   x)
+       , c (XListPat   x)
+       , c (XTuplePat  x)
+       , c (XSumPat    x)
+       , c (XViewPat   x)
+       , c (XSplicePat x)
+       , c (XLitPat    x)
+       , c (XNPat      x)
+       , c (XNPlusKPat x)
+       , c (XSigPat    x)
+       , c (XCoPat     x)
+       , c (XXPat      x)
+       )
+
+-- =====================================================================
+-- Type families for the HsTypes type families
+
+type family XHsQTvs       x
+type family XXLHsQTyVars  x
+
+type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) =
+       ( c (XHsQTvs       x)
+       , c (XXLHsQTyVars  x)
+       )
+
+-- -------------------------------------
+
+type family XHsIB              x b
+type family XXHsImplicitBndrs  x b
+
+type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XHsIB              x b)
+       , c (XXHsImplicitBndrs  x b)
+       )
+
+-- -------------------------------------
+
+type family XHsWC              x b
+type family XXHsWildCardBndrs  x b
+
+type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) =
+       ( c (XHsWC              x b)
+       , c (XXHsWildCardBndrs  x b)
+       )
+
+-- -------------------------------------
+
+type family XForAllTy        x
+type family XQualTy          x
+type family XTyVar           x
+type family XAppTy           x
+type family XFunTy           x
+type family XListTy          x
+type family XTupleTy         x
+type family XSumTy           x
+type family XOpTy            x
+type family XParTy           x
+type family XIParamTy        x
+type family XStarTy          x
+type family XKindSig         x
+type family XSpliceTy        x
+type family XDocTy           x
+type family XBangTy          x
+type family XRecTy           x
+type family XExplicitListTy  x
+type family XExplicitTupleTy x
+type family XTyLit           x
+type family XWildCardTy      x
+type family XXType           x
+
+-- | Helper to apply a constraint to all extension points. It has one
+-- entry per extension point type family.
+type ForallXType (c :: * -> Constraint) (x :: *) =
+       ( c (XForAllTy        x)
+       , c (XQualTy          x)
+       , c (XTyVar           x)
+       , c (XAppTy           x)
+       , c (XFunTy           x)
+       , c (XListTy          x)
+       , c (XTupleTy         x)
+       , c (XSumTy           x)
+       , c (XOpTy            x)
+       , c (XParTy           x)
+       , c (XIParamTy        x)
+       , c (XStarTy          x)
+       , c (XKindSig         x)
+       , c (XSpliceTy        x)
+       , c (XDocTy           x)
+       , c (XBangTy          x)
+       , c (XRecTy           x)
+       , c (XExplicitListTy  x)
+       , c (XExplicitTupleTy x)
+       , c (XTyLit           x)
+       , c (XWildCardTy      x)
+       , c (XXType           x)
+       )
+
 -- ---------------------------------------------------------------------
 
--- | The 'SourceText' fields have been moved into the extension fields, thus
--- placing a requirement in the extension field to contain a 'SourceText' so
--- that the pretty printing and round tripping of source can continue to
--- operate.
---
--- The 'HasSourceText' class captures this requirement for the relevant fields.
-class HasSourceText a where
-  -- Provide setters to mimic existing constructors
-  noSourceText  :: a
-  sourceText    :: String -> a
-
-  setSourceText :: SourceText -> a
-  getSourceText :: a -> SourceText
-
--- | Provide a summary constraint that lists all the extension points requiring
--- the 'HasSourceText' class, so that it can be changed in one place as the
--- named extensions change throughout the AST.
-type SourceTextX x =
-  ( HasSourceText (XHsChar x)
-  , HasSourceText (XHsCharPrim x)
-  , HasSourceText (XHsString x)
-  , HasSourceText (XHsStringPrim x)
-  , HasSourceText (XHsIntPrim x)
-  , HasSourceText (XHsWordPrim x)
-  , HasSourceText (XHsInt64Prim x)
-  , HasSourceText (XHsWord64Prim x)
-  , HasSourceText (XHsInteger x)
-  )
+type family XUserTyVar   x
+type family XKindedTyVar x
+type family XXTyVarBndr  x
 
+type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
+       ( c (XUserTyVar      x)
+       , c (XKindedTyVar    x)
+       , c (XXTyVarBndr     x)
+       )
 
--- |  'SourceText' trivially implements 'HasSourceText'
-instance HasSourceText SourceText where
-  noSourceText    = NoSourceText
-  sourceText s    = SourceText s
+-- ---------------------------------------------------------------------
 
-  setSourceText s = s
-  getSourceText a = a
+type family XConDeclField  x
+type family XXConDeclField x
 
+type ForallXConDeclField (c :: * -> Constraint) (x :: *) =
+       ( c (XConDeclField  x)
+       , c (XXConDeclField x)
+       )
 
--- ----------------------------------------------------------------------
--- | Defaults for each annotation, used to simplify creation in arbitrary
--- contexts
-class HasDefault a where
-  def :: a
+-- ---------------------------------------------------------------------
+
+type family XCFieldOcc x
+type family XXFieldOcc x
+
+type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
+       ( c (XCFieldOcc x)
+       , c (XXFieldOcc x)
+       )
 
-instance HasDefault () where
-  def = ()
 
-instance HasDefault SourceText where
-  def = NoSourceText
+-- =====================================================================
+-- Type families for the HsImpExp type families
 
--- | Provide a single constraint that captures the requirement for a default
--- across all the extension points.
-type HasDefaultX x = ForallX HasDefault x
+type family XCImportDecl       x
+type family XXImportDecl       x
+
+type ForallXImportDecl (c :: * -> Constraint) (x :: *) =
+       ( c (XCImportDecl x)
+       , c (XXImportDecl x)
+       )
+
+-- -------------------------------------
+
+type family XIEVar             x
+type family XIEThingAbs        x
+type family XIEThingAll        x
+type family XIEThingWith       x
+type family XIEModuleContents  x
+type family XIEGroup           x
+type family XIEDoc             x
+type family XIEDocNamed        x
+type family XXIE               x
+
+type ForallXIE (c :: * -> Constraint) (x :: *) =
+       ( c (XIEVar x)
+       , c (XIEThingAbs        x)
+       , c (XIEThingAll        x)
+       , c (XIEThingWith       x)
+       , c (XIEModuleContents  x)
+       , c (XIEGroup           x)
+       , c (XIEDoc             x)
+       , c (XIEDocNamed        x)
+       , c (XXIE               x)
+       )
+
+-- -------------------------------------
+
+
+-- =====================================================================
+-- End of Type family definitions
+-- =====================================================================
 
 -- ----------------------------------------------------------------------
 -- | Conversion of annotations from one type index to another. This is required
@@ -252,38 +1051,58 @@ type ConvertIdX a b =
    XHsStringPrim a ~ XHsStringPrim b,
    XHsString a ~ XHsString b,
    XHsCharPrim a ~ XHsCharPrim b,
-   XHsChar a ~ XHsChar b)
-
+   XHsChar a ~ XHsChar b,
+   XXLit a ~ XXLit b)
 
 -- ----------------------------------------------------------------------
 
+-- Note [OutputableX]
+-- ~~~~~~~~~~~~~~~~~~
+--
+-- is required because the type family resolution
+-- process cannot determine that all cases are handled for a `GhcPass p`
+-- case where the cases are listed separately.
+--
+-- So
+--
+--   type instance XXHsIPBinds    (GhcPass p) = NoExt
 --
-type DataId p =
-  ( Data p
-  , ForallX Data p
-  , Data (NameOrRdrName (IdP p))
-
-  , Data (IdP p)
-  , Data (PostRn p (IdP p))
-  , Data (PostRn p (Located Name))
-  , Data (PostRn p Bool)
-  , Data (PostRn p Fixity)
-  , Data (PostRn p NameSet)
-  , Data (PostRn p [Name])
-
-  , Data (PostTc p (IdP p))
-  , Data (PostTc p Coercion)
-  , Data (PostTc p ConLike)
-  , Data (PostTc p HsWrapper)
-  , Data (PostTc p Type)
-  , Data (PostTc p [ConLike])
-  , Data (PostTc p [Type])
+-- will correctly deduce Outputable for (GhcPass p), but
+--
+--   type instance XIPBinds       GhcPs = NoExt
+--   type instance XIPBinds       GhcRn = NoExt
+--   type instance XIPBinds       GhcTc = TcEvBinds
+--
+-- will not.
+
+
+-- | Provide a summary constraint that gives all am Outputable constraint to
+-- extension points needing one
+type OutputableX p = -- See Note [OutputableX]
+  (
+    Outputable (XSigPat p)
+  , Outputable (XSigPat GhcRn)
+
+  , Outputable (XIPBinds    p)
+
+  , Outputable (XExprWithTySig p)
+  , Outputable (XExprWithTySig GhcRn)
+
+  , Outputable (XAppTypeE p)
+  , Outputable (XAppTypeE GhcRn)
+
+  , Outputable (XViaStrategy p)
+  , Outputable (XViaStrategy GhcRn)
+
   )
+-- TODO: Should OutputableX be included in OutputableBndrId?
 
+-- ----------------------------------------------------------------------
 
 -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
 -- the @id@ and the 'NameOrRdrName' type for it
 type OutputableBndrId id =
   ( OutputableBndr (NameOrRdrName (IdP id))
   , OutputableBndr (IdP id)
+  , OutputableX id
   )
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 79ff2876aa..39bd9b7e18 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -9,11 +9,14 @@ HsImpExp: Abstract syntax: imports, exports, interfaces
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 
 module HsImpExp where
 
+import GhcPrelude
+
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
 import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
@@ -38,7 +41,7 @@ One per \tr{import} declaration in a module.
 -}
 
 -- | Located Import Declaration
-type LImportDecl name = Located (ImportDecl name)
+type LImportDecl pass = Located (ImportDecl pass)
         -- ^ When in a list this may have
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
@@ -48,8 +51,9 @@ type LImportDecl name = Located (ImportDecl name)
 -- | Import Declaration
 --
 -- A single Haskell @import@ declaration.
-data ImportDecl name
+data ImportDecl pass
   = ImportDecl {
+      ideclExt       :: XCImportDecl pass,
       ideclSourceSrc :: SourceText,
                                  -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
@@ -59,9 +63,10 @@ data ImportDecl name
       ideclQualified :: Bool,          -- ^ True => qualified
       ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)
       ideclAs        :: Maybe (Located ModuleName),  -- ^ as Module
-      ideclHiding    :: Maybe (Bool, Located [LIE name])
+      ideclHiding    :: Maybe (Bool, Located [LIE pass])
                                        -- ^ (True => hiding, names)
     }
+  | XImportDecl (XXImportDecl pass)
      -- ^
      --  'ApiAnnotation.AnnKeywordId's
      --
@@ -78,10 +83,13 @@ data ImportDecl name
      --     to location in ideclHiding
 
      -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (ImportDecl name)
 
-simpleImportDecl :: ModuleName -> ImportDecl name
+type instance XCImportDecl  (GhcPass _) = NoExt
+type instance XXImportDecl  (GhcPass _) = NoExt
+
+simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)
 simpleImportDecl mn = ImportDecl {
+      ideclExt       = noExt,
       ideclSourceSrc = NoSourceText,
       ideclName      = noLoc mn,
       ideclPkgQual   = Nothing,
@@ -93,7 +101,8 @@ simpleImportDecl mn = ImportDecl {
       ideclHiding    = Nothing
     }
 
-instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where
+instance (p ~ GhcPass pass,OutputableBndrId p)
+       => Outputable (ImportDecl p) where
     ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
                     , ideclPkgQual = pkg
                     , ideclSource = from, ideclSafe = safe
@@ -130,6 +139,7 @@ instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where
 
         ppr_ies []  = text "()"
         ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
+    ppr (XImportDecl x) = ppr x
 
 {-
 ************************************************************************
@@ -156,7 +166,7 @@ type LIEWrappedName name = Located (IEWrappedName name)
 
 
 -- | Located Import or Export
-type LIE name = Located (IE name)
+type LIE pass = Located (IE pass)
         -- ^ When in a list this may have
         --
         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
@@ -164,11 +174,11 @@ type LIE name = Located (IE name)
         -- For details on above see note [Api annotations] in ApiAnnotation
 
 -- | Imported or exported entity.
-data IE name
-  = IEVar       (LIEWrappedName (IdP name))
+data IE pass
+  = IEVar       (XIEVar pass) (LIEWrappedName (IdP pass))
         -- ^ Imported or Exported Variable
 
-  | IEThingAbs  (LIEWrappedName (IdP name))
+  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName (IdP pass))
         -- ^ Imported or exported Thing with Absent list
         --
         -- The thing is a Class/Type (can't tell)
@@ -177,7 +187,7 @@ data IE name
 
         -- For details on above see note [Api annotations] in ApiAnnotation
         -- See Note [Located RdrNames] in HsExpr
-  | IEThingAll  (LIEWrappedName (IdP name))
+  | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))
         -- ^ Imported or exported Thing with All imported or exported
         --
         -- The thing is a Class/Type and the All refers to methods/constructors
@@ -189,10 +199,11 @@ data IE name
         -- For details on above see note [Api annotations] in ApiAnnotation
         -- See Note [Located RdrNames] in HsExpr
 
-  | IEThingWith (LIEWrappedName (IdP name))
+  | IEThingWith (XIEThingWith pass)
+                (LIEWrappedName (IdP pass))
                 IEWildcard
-                [LIEWrappedName (IdP name)]
-                [Located (FieldLbl (IdP name))]
+                [LIEWrappedName (IdP pass)]
+                [Located (FieldLbl (IdP pass))]
         -- ^ Imported or exported Thing With given imported or exported
         --
         -- The thing is a Class/Type and the imported or exported things are
@@ -203,7 +214,7 @@ data IE name
         --                                   'ApiAnnotation.AnnType'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | IEModuleContents  (Located ModuleName)
+  | IEModuleContents  (XIEModuleContents pass) (Located ModuleName)
         -- ^ Imported or exported module contents
         --
         -- (Export Only)
@@ -211,12 +222,20 @@ data IE name
         -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-  | IEGroup             Int HsDocString  -- ^ Doc section heading
-  | IEDoc               HsDocString      -- ^ Some documentation
-  | IEDocNamed          String           -- ^ Reference to named doc
-  -- deriving (Eq, Data)
-deriving instance (Eq name, Eq (IdP name)) => Eq (IE name)
-deriving instance (DataId name)             => Data (IE name)
+  | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading
+  | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation
+  | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc
+  | XIE (XXIE pass)
+
+type instance XIEVar             (GhcPass _) = NoExt
+type instance XIEThingAbs        (GhcPass _) = NoExt
+type instance XIEThingAll        (GhcPass _) = NoExt
+type instance XIEThingWith       (GhcPass _) = NoExt
+type instance XIEModuleContents  (GhcPass _) = NoExt
+type instance XIEGroup           (GhcPass _) = NoExt
+type instance XIEDoc             (GhcPass _) = NoExt
+type instance XIEDocNamed        (GhcPass _) = NoExt
+type instance XXIE               (GhcPass _) = NoExt
 
 -- | Imported or Exported Wildcard
 data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)
@@ -239,22 +258,23 @@ See Note [Representing fields in AvailInfo] in Avail for more details.
 -}
 
 ieName :: IE pass -> IdP pass
-ieName (IEVar (L _ n))              = ieWrappedName n
-ieName (IEThingAbs  (L _ n))        = ieWrappedName n
-ieName (IEThingWith (L _ n) _ _ _)  = ieWrappedName n
-ieName (IEThingAll  (L _ n))        = ieWrappedName n
+ieName (IEVar _ (L _ n))              = ieWrappedName n
+ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n
+ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n
+ieName (IEThingAll  _ (L _ n))        = ieWrappedName n
 ieName _ = panic "ieName failed pattern match!"
 
 ieNames :: IE pass -> [IdP pass]
-ieNames (IEVar       (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingAbs  (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingAll  (L _ n)   )     = [ieWrappedName n]
-ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n
+ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]
+ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]
+ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]
+ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n
                                        : map (ieWrappedName . unLoc) ns
-ieNames (IEModuleContents _    )     = []
-ieNames (IEGroup          _ _  )     = []
-ieNames (IEDoc            _    )     = []
-ieNames (IEDocNamed       _    )     = []
+ieNames (IEModuleContents {})     = []
+ieNames (IEGroup          {})     = []
+ieNames (IEDoc            {})     = []
+ieNames (IEDocNamed       {})     = []
+ieNames (XIE {}) = panic "ieNames"
 
 ieWrappedName :: IEWrappedName name -> name
 ieWrappedName (IEName    (L _ n)) = n
@@ -272,11 +292,11 @@ replaceWrappedName (IEType    (L l _)) n = IEType    (L l n)
 replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
 
-instance (OutputableBndrId pass) => Outputable (IE pass) where
-    ppr (IEVar          var) = ppr (unLoc var)
-    ppr (IEThingAbs     thing) = ppr (unLoc thing)
-    ppr (IEThingAll     thing) = hcat [ppr (unLoc thing), text "(..)"]
-    ppr (IEThingWith thing wc withs flds)
+instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
+    ppr (IEVar       _     var) = ppr (unLoc var)
+    ppr (IEThingAbs  _   thing) = ppr (unLoc thing)
+    ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]
+    ppr (IEThingWith _ thing wc withs flds)
         = ppr (unLoc thing) <> parens (fsep (punctuate comma
                                               (ppWiths ++
                                               map (ppr . flLabel . unLoc) flds)))
@@ -288,11 +308,12 @@ instance (OutputableBndrId pass) => Outputable (IE pass) where
               IEWildcard pos ->
                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
                 in bs ++ [text ".."] ++ as
-    ppr (IEModuleContents mod')
+    ppr (IEModuleContents _ mod')
         = text "module" <+> ppr mod'
-    ppr (IEGroup n _)           = text ("<IEGroup: " ++ show n ++ ">")
-    ppr (IEDoc doc)             = ppr doc
-    ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
+    ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")
+    ppr (IEDoc _ doc)             = ppr doc
+    ppr (IEDocNamed _ string)     = text ("<IEDocNamed: " ++ string ++ ">")
+    ppr (XIE x) = ppr x
 
 instance (HasOccName name) => HasOccName (IEWrappedName name) where
   occName w = occName (ieWrappedName w)
diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs
new file mode 100644
index 0000000000..9a9f21d046
--- /dev/null
+++ b/compiler/hsSyn/HsInstances.hs
@@ -0,0 +1,416 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HsInstances where
+
+-- This module defines the Data instances for the hsSyn AST.
+
+-- It happens here to avoid massive constraint types on the AST with concomitant
+-- slow GHC bootstrap times.
+
+-- UndecidableInstances ?
+
+import Data.Data hiding ( Fixity )
+
+import GhcPrelude
+import HsExtension
+import HsBinds
+import HsDecls
+import HsExpr
+import HsLit
+import HsTypes
+import HsPat
+import HsImpExp
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsSyn -----------------------------------------
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsBinds ---------------------------------------
+
+-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR)
+deriving instance Data (HsLocalBindsLR GhcPs GhcPs)
+deriving instance Data (HsLocalBindsLR GhcPs GhcRn)
+deriving instance Data (HsLocalBindsLR GhcRn GhcRn)
+deriving instance Data (HsLocalBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR)
+deriving instance Data (HsValBindsLR GhcPs GhcPs)
+deriving instance Data (HsValBindsLR GhcPs GhcRn)
+deriving instance Data (HsValBindsLR GhcRn GhcRn)
+deriving instance Data (HsValBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
+deriving instance Data (NHsValBindsLR GhcPs)
+deriving instance Data (NHsValBindsLR GhcRn)
+deriving instance Data (NHsValBindsLR GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
+deriving instance Data (HsBindLR GhcPs GhcPs)
+deriving instance Data (HsBindLR GhcPs GhcRn)
+deriving instance Data (HsBindLR GhcRn GhcRn)
+deriving instance Data (HsBindLR GhcTc GhcTc)
+
+-- deriving instance (DataId p)       => Data (ABExport p)
+deriving instance Data (ABExport GhcPs)
+deriving instance Data (ABExport GhcRn)
+deriving instance Data (ABExport GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR)
+deriving instance Data (PatSynBind GhcPs GhcPs)
+deriving instance Data (PatSynBind GhcPs GhcRn)
+deriving instance Data (PatSynBind GhcRn GhcRn)
+deriving instance Data (PatSynBind GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (HsIPBinds p)
+deriving instance Data (HsIPBinds GhcPs)
+deriving instance Data (HsIPBinds GhcRn)
+deriving instance Data (HsIPBinds GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (IPBind p)
+deriving instance Data (IPBind GhcPs)
+deriving instance Data (IPBind GhcRn)
+deriving instance Data (IPBind GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (Sig p)
+deriving instance Data (Sig GhcPs)
+deriving instance Data (Sig GhcRn)
+deriving instance Data (Sig GhcTc)
+
+-- deriving instance (DataId p)       => Data (FixitySig p)
+deriving instance Data (FixitySig GhcPs)
+deriving instance Data (FixitySig GhcRn)
+deriving instance Data (FixitySig GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (HsPatSynDir p)
+deriving instance Data (HsPatSynDir GhcPs)
+deriving instance Data (HsPatSynDir GhcRn)
+deriving instance Data (HsPatSynDir GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsDecls ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (HsDecl p)
+deriving instance Data (HsDecl GhcPs)
+deriving instance Data (HsDecl GhcRn)
+deriving instance Data (HsDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsGroup p)
+deriving instance Data (HsGroup GhcPs)
+deriving instance Data (HsGroup GhcRn)
+deriving instance Data (HsGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (SpliceDecl p)
+deriving instance Data (SpliceDecl GhcPs)
+deriving instance Data (SpliceDecl GhcRn)
+deriving instance Data (SpliceDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClDecl p)
+deriving instance Data (TyClDecl GhcPs)
+deriving instance Data (TyClDecl GhcRn)
+deriving instance Data (TyClDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
+deriving instance Data (TyClGroup GhcPs)
+deriving instance Data (TyClGroup GhcRn)
+deriving instance Data (TyClGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p)
+deriving instance Data (FamilyResultSig GhcPs)
+deriving instance Data (FamilyResultSig GhcRn)
+deriving instance Data (FamilyResultSig GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyDecl p)
+deriving instance Data (FamilyDecl GhcPs)
+deriving instance Data (FamilyDecl GhcRn)
+deriving instance Data (FamilyDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p)
+deriving instance Data (InjectivityAnn GhcPs)
+deriving instance Data (InjectivityAnn GhcRn)
+deriving instance Data (InjectivityAnn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyInfo p)
+deriving instance Data (FamilyInfo GhcPs)
+deriving instance Data (FamilyInfo GhcRn)
+deriving instance Data (FamilyInfo GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDataDefn p)
+deriving instance Data (HsDataDefn GhcPs)
+deriving instance Data (HsDataDefn GhcRn)
+deriving instance Data (HsDataDefn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p)
+deriving instance Data (HsDerivingClause GhcPs)
+deriving instance Data (HsDerivingClause GhcRn)
+deriving instance Data (HsDerivingClause GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDecl p)
+deriving instance Data (ConDecl GhcPs)
+deriving instance Data (ConDecl GhcRn)
+deriving instance Data (ConDecl GhcTc)
+
+-- deriving instance DataIdLR p p   => Data (TyFamInstDecl p)
+deriving instance Data (TyFamInstDecl GhcPs)
+deriving instance Data (TyFamInstDecl GhcRn)
+deriving instance Data (TyFamInstDecl GhcTc)
+
+-- deriving instance DataIdLR p p   => Data (DataFamInstDecl p)
+deriving instance Data (DataFamInstDecl GhcPs)
+deriving instance Data (DataFamInstDecl GhcRn)
+deriving instance Data (DataFamInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs)
+
+-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p)
+deriving instance Data (ClsInstDecl GhcPs)
+deriving instance Data (ClsInstDecl GhcRn)
+deriving instance Data (ClsInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InstDecl p)
+deriving instance Data (InstDecl GhcPs)
+deriving instance Data (InstDecl GhcRn)
+deriving instance Data (InstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DerivDecl p)
+deriving instance Data (DerivDecl GhcPs)
+deriving instance Data (DerivDecl GhcRn)
+deriving instance Data (DerivDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DerivStrategy p)
+deriving instance Data (DerivStrategy GhcPs)
+deriving instance Data (DerivStrategy GhcRn)
+deriving instance Data (DerivStrategy GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DefaultDecl p)
+deriving instance Data (DefaultDecl GhcPs)
+deriving instance Data (DefaultDecl GhcRn)
+deriving instance Data (DefaultDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ForeignDecl p)
+deriving instance Data (ForeignDecl GhcPs)
+deriving instance Data (ForeignDecl GhcRn)
+deriving instance Data (ForeignDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
+deriving instance Data (RuleDecls GhcPs)
+deriving instance Data (RuleDecls GhcRn)
+deriving instance Data (RuleDecls GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecl p)
+deriving instance Data (RuleDecl GhcPs)
+deriving instance Data (RuleDecl GhcRn)
+deriving instance Data (RuleDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleBndr p)
+deriving instance Data (RuleBndr GhcPs)
+deriving instance Data (RuleBndr GhcRn)
+deriving instance Data (RuleBndr GhcTc)
+
+-- deriving instance (DataId p)     => Data (WarnDecls p)
+deriving instance Data (WarnDecls GhcPs)
+deriving instance Data (WarnDecls GhcRn)
+deriving instance Data (WarnDecls GhcTc)
+
+-- deriving instance (DataId p)     => Data (WarnDecl p)
+deriving instance Data (WarnDecl GhcPs)
+deriving instance Data (WarnDecl GhcRn)
+deriving instance Data (WarnDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (AnnDecl p)
+deriving instance Data (AnnDecl GhcPs)
+deriving instance Data (AnnDecl GhcRn)
+deriving instance Data (AnnDecl GhcTc)
+
+-- deriving instance (DataId p)     => Data (RoleAnnotDecl p)
+deriving instance Data (RoleAnnotDecl GhcPs)
+deriving instance Data (RoleAnnotDecl GhcRn)
+deriving instance Data (RoleAnnotDecl GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsExpr ----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
+deriving instance Data (SyntaxExpr GhcPs)
+deriving instance Data (SyntaxExpr GhcRn)
+deriving instance Data (SyntaxExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsExpr p)
+deriving instance Data (HsExpr GhcPs)
+deriving instance Data (HsExpr GhcRn)
+deriving instance Data (HsExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsTupArg p)
+deriving instance Data (HsTupArg GhcPs)
+deriving instance Data (HsTupArg GhcRn)
+deriving instance Data (HsTupArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmd p)
+deriving instance Data (HsCmd GhcPs)
+deriving instance Data (HsCmd GhcRn)
+deriving instance Data (HsCmd GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmdTop p)
+deriving instance Data (HsCmdTop GhcPs)
+deriving instance Data (HsCmdTop GhcRn)
+deriving instance Data (HsCmdTop GhcTc)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
+deriving instance (Data body) => Data (MatchGroup GhcPs body)
+deriving instance (Data body) => Data (MatchGroup GhcRn body)
+deriving instance (Data body) => Data (MatchGroup GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (Match      p body)
+deriving instance (Data body) => Data (Match      GhcPs body)
+deriving instance (Data body) => Data (Match      GhcRn body)
+deriving instance (Data body) => Data (Match      GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs      p body)
+deriving instance (Data body) => Data (GRHSs     GhcPs body)
+deriving instance (Data body) => Data (GRHSs     GhcRn body)
+deriving instance (Data body) => Data (GRHSs     GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHS       p body)
+deriving instance (Data body) => Data (GRHS     GhcPs body)
+deriving instance (Data body) => Data (GRHS     GhcRn body)
+deriving instance (Data body) => Data (GRHS     GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR   p p body)
+deriving instance (Data body) => Data (StmtLR   GhcPs GhcPs body)
+deriving instance (Data body) => Data (StmtLR   GhcPs GhcRn body)
+deriving instance (Data body) => Data (StmtLR   GhcRn GhcRn body)
+deriving instance (Data body) => Data (StmtLR   GhcTc GhcTc body)
+
+deriving instance Data RecStmtTc
+
+-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p)
+deriving instance Data (ParStmtBlock GhcPs GhcPs)
+deriving instance Data (ParStmtBlock GhcPs GhcRn)
+deriving instance Data (ParStmtBlock GhcRn GhcRn)
+deriving instance Data (ParStmtBlock GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p)
+deriving instance Data (ApplicativeArg GhcPs)
+deriving instance Data (ApplicativeArg GhcRn)
+deriving instance Data (ApplicativeArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplice p)
+deriving instance Data (HsSplice GhcPs)
+deriving instance Data (HsSplice GhcRn)
+deriving instance Data (HsSplice GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)
+deriving instance Data (HsSplicedThing GhcPs)
+deriving instance Data (HsSplicedThing GhcRn)
+deriving instance Data (HsSplicedThing GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsBracket p)
+deriving instance Data (HsBracket GhcPs)
+deriving instance Data (HsBracket GhcRn)
+deriving instance Data (HsBracket GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
+deriving instance Data (ArithSeqInfo GhcPs)
+deriving instance Data (ArithSeqInfo GhcRn)
+deriving instance Data (ArithSeqInfo GhcTc)
+
+deriving instance                   Data RecordConTc
+deriving instance                   Data CmdTopTc
+deriving instance                   Data PendingRnSplice
+deriving instance                   Data PendingTcSplice
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsLit ----------------------------------------
+
+-- deriving instance (DataId p) => Data (HsLit p)
+deriving instance Data (HsLit GhcPs)
+deriving instance Data (HsLit GhcRn)
+deriving instance Data (HsLit GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsOverLit p)
+deriving instance Data (HsOverLit GhcPs)
+deriving instance Data (HsOverLit GhcRn)
+deriving instance Data (HsOverLit GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsPat -----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (Pat p)
+deriving instance Data (Pat GhcPs)
+deriving instance Data (Pat GhcRn)
+deriving instance Data (Pat GhcTc)
+
+deriving instance Data ListPatTc
+
+-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)
+deriving instance (Data body) => Data (HsRecFields GhcPs body)
+deriving instance (Data body) => Data (HsRecFields GhcRn body)
+deriving instance (Data body) => Data (HsRecFields GhcTc body)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsTypes ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p)
+deriving instance Data (LHsQTyVars GhcPs)
+deriving instance Data (LHsQTyVars GhcRn)
+deriving instance Data (LHsQTyVars GhcTc)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
+deriving instance Data (HsTyVarBndr GhcPs)
+deriving instance Data (HsTyVarBndr GhcRn)
+deriving instance Data (HsTyVarBndr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsType p)
+deriving instance Data (HsType GhcPs)
+deriving instance Data (HsType GhcRn)
+deriving instance Data (HsType GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
+deriving instance Data (ConDeclField GhcPs)
+deriving instance Data (ConDeclField GhcRn)
+deriving instance Data (ConDeclField GhcTc)
+
+-- deriving instance (DataId p)     => Data (FieldOcc p)
+deriving instance Data (FieldOcc GhcPs)
+deriving instance Data (FieldOcc GhcRn)
+deriving instance Data (FieldOcc GhcTc)
+
+-- deriving instance DataId p       => Data (AmbiguousFieldOcc p)
+deriving instance Data (AmbiguousFieldOcc GhcPs)
+deriving instance Data (AmbiguousFieldOcc GhcRn)
+deriving instance Data (AmbiguousFieldOcc GhcTc)
+
+
+-- deriving instance (DataId name) => Data (ImportDecl name)
+deriving instance Data (ImportDecl GhcPs)
+deriving instance Data (ImportDecl GhcRn)
+deriving instance Data (ImportDecl GhcTc)
+
+-- deriving instance (DataId name)             => Data (IE name)
+deriving instance Data (IE GhcPs)
+deriving instance Data (IE GhcRn)
+deriving instance Data (IE GhcTc)
+
+-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name)
+deriving instance Eq (IE GhcPs)
+deriving instance Eq (IE GhcRn)
+deriving instance Eq (IE GhcTc)
+
+-- ---------------------------------------------------------------------
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 1044f9bca6..d1411bd750 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -8,7 +8,6 @@
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
@@ -19,10 +18,12 @@ module HsLit where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
 import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
                     negateFractionalLit,SourceText(..),pprWithSourceText )
-import Type       ( Type )
+import Type
 import Outputable
 import FastString
 import HsExtension
@@ -75,8 +76,22 @@ data HsLit x
   | HsDoublePrim (XHsDoublePrim x) FractionalLit
       -- ^ Unboxed Double
 
-deriving instance (DataId x) => Data (HsLit x)
+  | XLit (XXLit x)
 
+type instance XHsChar       (GhcPass _) = SourceText
+type instance XHsCharPrim   (GhcPass _) = SourceText
+type instance XHsString     (GhcPass _) = SourceText
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt        (GhcPass _) = NoExt
+type instance XHsIntPrim    (GhcPass _) = SourceText
+type instance XHsWordPrim   (GhcPass _) = SourceText
+type instance XHsInt64Prim  (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger    (GhcPass _) = SourceText
+type instance XHsRat        (GhcPass _) = NoExt
+type instance XHsFloatPrim  (GhcPass _) = NoExt
+type instance XHsDoublePrim (GhcPass _) = NoExt
+type instance XXLit         (GhcPass _) = NoExt
 
 instance Eq (HsLit x) where
   (HsChar _ x1)       == (HsChar _ x2)       = x1==x2
@@ -97,11 +112,24 @@ instance Eq (HsLit x) where
 -- | Haskell Overloaded Literal
 data HsOverLit p
   = OverLit {
-        ol_val :: OverLitVal,
-        ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable]
-        ol_witness :: HsExpr p,         -- Note [Overloaded literal witnesses]
-        ol_type :: PostTc p Type }
-deriving instance (DataId p, DataId p) => Data (HsOverLit p)
+      ol_ext :: (XOverLit p),
+      ol_val :: OverLitVal,
+      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]
+
+  | XOverLit
+      (XXOverLit p)
+
+data OverLitTc
+  = OverLitTc {
+        ol_rebindable :: Bool, -- Note [ol_rebindable]
+        ol_type :: Type }
+  deriving Data
+
+type instance XOverLit GhcPs = NoExt
+type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = NoExt
 
 -- Note [Literal source text] in BasicTypes for SourceText fields in
 -- the following
@@ -117,8 +145,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
 negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
 negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
 
-overLitType :: HsOverLit p -> PostTc p Type
-overLitType = ol_type
+overLitType :: HsOverLit GhcTc -> Type
+overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType XOverLit{} = panic "overLitType"
 
 -- | Convert a literal from one index type to another, updating the annotations
 -- according to the relevant 'Convertable' instance
@@ -136,6 +165,7 @@ convertLit (HsInteger a x b)  = (HsInteger (convert a) x b)
 convertLit (HsRat a x b)      = (HsRat (convert a) x b)
 convertLit (HsFloatPrim a x)  = (HsFloatPrim (convert a) x)
 convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
+convertLit (XLit a)           = (XLit (convert a))
 
 {-
 Note [ol_rebindable]
@@ -169,8 +199,10 @@ found to have.
 
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module MatchLit)
-instance Eq (HsOverLit p) where
-  (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
+  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
+  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2
+  _ == _ = panic "Eq HsOverLit"
 
 instance Eq OverLitVal where
   (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2
@@ -178,8 +210,10 @@ instance Eq OverLitVal where
   (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2
   _                   == _                   = False
 
-instance Ord (HsOverLit p) where
-  compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
+  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
+  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2
+  compare _ _ = panic "Ord HsOverLit"
 
 instance Ord OverLitVal where
   compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2
@@ -193,38 +227,33 @@ instance Ord OverLitVal where
   compare (HsIsString _ _)    (HsFractional _)    = GT
 
 -- Instance specific to GhcPs, need the SourceText
-instance (SourceTextX x) => Outputable (HsLit x) where
-    ppr (HsChar st c)       = pprWithSourceText (getSourceText st) (pprHsChar c)
-    ppr (HsCharPrim st c)
-     = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
-    ppr (HsString st s)
-      = pprWithSourceText (getSourceText st) (pprHsString s)
-    ppr (HsStringPrim st s)
-      = pprWithSourceText (getSourceText st) (pprHsBytes s)
+instance p ~ GhcPass pass => Outputable (HsLit p) where
+    ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)
+    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)
+    ppr (HsString st s)     = pprWithSourceText st (pprHsString s)
+    ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
     ppr (HsInt _ i)
       = pprWithSourceText (il_text i) (integer (il_value i))
-    ppr (HsInteger st i _)  = pprWithSourceText (getSourceText st) (integer i)
+    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)
     ppr (HsRat _ f _)       = ppr f
     ppr (HsFloatPrim _ f)   = ppr f <> primFloatSuffix
     ppr (HsDoublePrim _ d)  = ppr d <> primDoubleSuffix
-    ppr (HsIntPrim st i)
-      = pprWithSourceText (getSourceText st) (pprPrimInt i)
-    ppr (HsWordPrim st w)
-      = pprWithSourceText (getSourceText st) (pprPrimWord w)
-    ppr (HsInt64Prim st i)
-      = pp_st_suffix (getSourceText st) primInt64Suffix  (pprPrimInt64 i)
-    ppr (HsWord64Prim st w)
-      = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
+    ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)
+    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)
+    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)
+    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
+    ppr (XLit x) = ppr x
 
 pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
 pp_st_suffix NoSourceText         _ doc = doc
 pp_st_suffix (SourceText st) suffix _   = text st <> suffix
 
 -- in debug mode, print the expression that it's resolved to, too
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsOverLit p) where
   ppr (OverLit {ol_val=val, ol_witness=witness})
-        = ppr val <+> (ifPprDebug (parens (pprExpr witness)))
+        = ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+  ppr (XOverLit x) = ppr x
 
 instance Outputable OverLitVal where
   ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))
@@ -237,11 +266,10 @@ instance Outputable OverLitVal where
 -- mainly for too reasons:
 --  * We do not want to expose their internal representation
 --  * The warnings become too messy
-pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
+pmPprHsLit :: HsLit (GhcPass x) -> SDoc
 pmPprHsLit (HsChar _ c)       = pprHsChar c
 pmPprHsLit (HsCharPrim _ c)   = pprHsChar c
-pmPprHsLit (HsString st s)    = pprWithSourceText (getSourceText st)
-                                                  (pprHsString s)
+pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)
 pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
 pmPprHsLit (HsInt _ i)        = integer (il_value i)
 pmPprHsLit (HsIntPrim _ i)    = integer i
@@ -252,3 +280,35 @@ pmPprHsLit (HsInteger _ i _)  = integer i
 pmPprHsLit (HsRat _ f _)      = ppr f
 pmPprHsLit (HsFloatPrim _ f)  = ppr f
 pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x)           = ppr x
+
+-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
+-- to be parenthesized under precedence @p@.
+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens p = go
+  where
+    go (HsChar {})        = False
+    go (HsCharPrim {})    = False
+    go (HsString {})      = False
+    go (HsStringPrim {})  = False
+    go (HsInt _ x)        = p > topPrec && il_neg x
+    go (HsIntPrim _ x)    = p > topPrec && x < 0
+    go (HsWordPrim {})    = False
+    go (HsInt64Prim _ x)  = p > topPrec && x < 0
+    go (HsWord64Prim {})  = False
+    go (HsInteger _ x _)  = p > topPrec && x < 0
+    go (HsRat _ x _)      = p > topPrec && fl_neg x
+    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x
+    go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+    go (XLit _)           = False
+
+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
+-- @ol@ needs to be parenthesized under precedence @p@.
+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
+  where
+    go :: OverLitVal -> Bool
+    go (HsIntegral x)   = p > topPrec && il_neg x
+    go (HsFractional x) = p > topPrec && fl_neg x
+    go (HsIsString {})  = False
+hsOverLitNeedsParens _ (XOverLit { }) = False
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index f7d18768df..6f65487411 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -18,6 +18,7 @@
 
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
+        ListPatTc(..),
 
         HsConPatDetails, hsConPatArgs,
         HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -29,15 +30,17 @@ module HsPat (
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
         looksLazyPatBind,
-        isBangedLPat, isBangedPatBind,
-        hsPatNeedsParens,
+        isBangedLPat,
+        patNeedsParens, parenthesizePat,
         isIrrefutableHsPat,
 
-        collectEvVarsPats,
+        collectEvVarsPat, collectEvVarsPats,
 
         pprParendLPat, pprConArgs
     ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)
 
 -- friends:
@@ -76,42 +79,47 @@ type LPat p = Located (Pat p)
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Pat p
   =     ------------ Simple patterns ---------------
-    WildPat     (PostTc p Type)        -- ^ Wildcard Pattern
+    WildPat     (XWildPat p)        -- ^ Wildcard Pattern
         -- The sole reason for a type on a WildPat is to
         -- support hsPatType :: Pat Id -> Type
 
        -- AZ:TODO above comment needs to be updated
-  | VarPat      (Located (IdP p))  -- ^ Variable Pattern
+  | VarPat      (XVarPat p)
+                (Located (IdP p))  -- ^ Variable Pattern
 
                              -- See Note [Located RdrNames] in HsExpr
-  | LazyPat     (LPat p)                -- ^ Lazy Pattern
+  | LazyPat     (XLazyPat p)
+                (LPat p)                -- ^ Lazy Pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | AsPat       (Located (IdP p)) (LPat p)    -- ^ As pattern
+  | AsPat       (XAsPat p)
+                (Located (IdP p)) (LPat p)    -- ^ As pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | ParPat      (LPat p)                -- ^ Parenthesised pattern
+  | ParPat      (XParPat p)
+                (LPat p)                -- ^ Parenthesised pattern
                                         -- See Note [Parens in HsSyn] in HsExpr
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
     --                                    'ApiAnnotation.AnnClose' @')'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-  | BangPat     (LPat p)                -- ^ Bang pattern
+  | BangPat     (XBangPat p)
+                (LPat p)                -- ^ Bang pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
         ------------ Lists, tuples, arrays ---------------
-  | ListPat     [LPat p]
-                (PostTc p Type)                      -- The type of the elements
-                (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
+  | ListPat     (XListPat p)
+                [LPat p]
                    -- For OverloadedLists a Just (ty,fn) gives
                    -- overall type of the pattern, and the toList
-                   -- function to convert the scrutinee to a list value
+-- function to convert the scrutinee to a list value
+
     -- ^ Syntactic List
     --
     -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
@@ -119,12 +127,13 @@ data Pat p
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | TuplePat    [LPat p]         -- Tuple sub-patterns
+  | TuplePat    (XTuplePat p)
+                  -- after typechecking, holds the types of the tuple components
+                [LPat p]         -- Tuple sub-patterns
                 Boxity           -- UnitPat is TuplePat []
-                [PostTc p Type]  -- [] before typechecker, filled in afterwards
-                                 -- with the types of the tuple components
-        -- You might think that the PostTc p Type was redundant, because we can
-        -- get the pattern type by getting the types of the sub-patterns.
+        -- You might think that the post typechecking Type was redundant,
+        -- because we can get the pattern type by getting the types of the
+        -- sub-patterns.
         -- But it's essential
         --      data T a where
         --        T1 :: Int -> T Int
@@ -144,12 +153,12 @@ data Pat p
     --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
     --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
 
-  | SumPat      (LPat p)           -- Sum sub-pattern
-                ConTag             -- Alternative (one-based)
-                Arity              -- Arity
-                (PostTc p [Type])  -- PlaceHolder before typechecker, filled in
+  | SumPat      (XSumPat p)        -- PlaceHolder before typechecker, filled in
                                    -- afterwards with the types of the
                                    -- alternative
+                (LPat p)           -- Sum sub-pattern
+                ConTag             -- Alternative (one-based)
+                Arity              -- Arity (INVARIANT: ≥ 2)
     -- ^ Anonymous sum pattern
     --
     -- - 'ApiAnnotation.AnnKeywordId' :
@@ -157,12 +166,7 @@ data Pat p
     --            'ApiAnnotation.AnnClose' @'#)'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-  | PArrPat     [LPat p]                -- Syntactic parallel array
-                (PostTc p Type)         -- The type of the elements
-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-    --                                    'ApiAnnotation.AnnClose' @':]'@
 
-    -- For details on above see note [Api annotations] in ApiAnnotation
         ------------ Constructor patterns ---------------
   | ConPatIn    (Located (IdP p))
                 (HsConPatDetails p)
@@ -193,11 +197,11 @@ data Pat p
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | ViewPat       (LHsExpr p)
+  | ViewPat       (XViewPat p)     -- The overall type of the pattern
+                                   -- (= the argument type of the view function)
+                                   -- for hsPatType.
+                  (LHsExpr p)
                   (LPat p)
-                  (PostTc p Type)   -- The overall type of the pattern
-                                    -- (= the argument type of the view function)
-                                    -- for hsPatType.
     -- ^ View Pattern
 
         ------------ Pattern splices ---------------
@@ -205,31 +209,34 @@ data Pat p
   --        'ApiAnnotation.AnnClose' @')'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SplicePat       (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
+  | SplicePat       (XSplicePat p)
+                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
 
         ------------ Literal and n+k patterns ---------------
-  | LitPat          (HsLit p)           -- ^ Literal Pattern
+  | LitPat          (XLitPat p)
+                    (HsLit p)           -- ^ Literal Pattern
                                         -- Used for *non-overloaded* literal patterns:
                                         -- Int#, Char#, Int, Char, String, etc.
 
   | NPat                -- Natural Pattern
                         -- Used for all overloaded literals,
                         -- including overloaded strings with -XOverloadedStrings
+                    (XNPat p)            -- Overall type of pattern. Might be
+                                         -- different than the literal's type
+                                         -- if (==) or negate changes the type
                     (Located (HsOverLit p))     -- ALWAYS positive
                     (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
                                            -- negative patterns, Nothing
                                            -- otherwise
                     (SyntaxExpr p)       -- Equality checker, of type t->t->Bool
-                    (PostTc p Type)      -- Overall type of pattern. Might be
-                                         -- different than the literal's type
-                                         -- if (==) or negate changes the type
 
   -- ^ Natural Pattern
   --
   -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | NPlusKPat       (Located (IdP p))        -- n+k pattern
+  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern
+                    (Located (IdP p))        -- n+k pattern
                     (Located (HsOverLit p))  -- It'll always be an HsIntegral
                     (HsOverLit p)       -- See Note [NPlusK patterns] in TcPat
                      -- NB: This could be (PostTc ...), but that induced a
@@ -237,24 +244,22 @@ data Pat p
 
                     (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool
                     (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)
-                    (PostTc p Type)  -- Type of overall pattern
   -- ^ n+k pattern
 
         ------------ Pattern type signatures ---------------
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SigPatIn        (LPat p)                  -- Pattern with a type signature
-                    (LHsSigWcType p)          -- Signature can bind both
-                                              -- kind and type vars
-    -- ^ Pattern with a type signature
-
-  | SigPatOut       (LPat p)
-                    Type
+  | SigPat          (XSigPat p)          -- Before typechecker
+                                         --  Signature can bind both
+                                         --  kind and type vars
+                                         -- After typechecker: Type
+                    (LPat p)                -- Pattern with a type signature
     -- ^ Pattern with a type signature
 
         ------------ Pattern coercions (translation only) ---------------
-  | CoPat       HsWrapper           -- Coercion Pattern
+  | CoPat       (XCoPat p)
+                HsWrapper           -- Coercion Pattern
                                     -- If co :: t1 ~ t2, p :: t2,
                                     -- then (CoPat co p) :: t1
                 (Pat p)             -- Why not LPat?  Ans: existing locn will do
@@ -262,7 +267,67 @@ data Pat p
         -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
         -- the scrutinee, followed by a match on 'pat'
     -- ^ Coercion Pattern
-deriving instance (DataId p) => Data (Pat p)
+
+  -- | Trees that Grow extension point for new constructors
+  | XPat
+      (XXPat p)
+
+-- ---------------------------------------------------------------------
+
+data ListPatTc
+  = ListPatTc
+      Type                             -- The type of the elements
+      (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax
+
+type instance XWildPat GhcPs = NoExt
+type instance XWildPat GhcRn = NoExt
+type instance XWildPat GhcTc = Type
+
+type instance XVarPat  (GhcPass _) = NoExt
+type instance XLazyPat (GhcPass _) = NoExt
+type instance XAsPat   (GhcPass _) = NoExt
+type instance XParPat  (GhcPass _) = NoExt
+type instance XBangPat (GhcPass _) = NoExt
+
+-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
+-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
+-- `SyntaxExpr`
+type instance XListPat GhcPs = NoExt
+type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
+type instance XListPat GhcTc = ListPatTc
+
+type instance XTuplePat GhcPs = NoExt
+type instance XTuplePat GhcRn = NoExt
+type instance XTuplePat GhcTc = [Type]
+
+type instance XSumPat GhcPs = NoExt
+type instance XSumPat GhcRn = NoExt
+type instance XSumPat GhcTc = [Type]
+
+type instance XViewPat GhcPs = NoExt
+type instance XViewPat GhcRn = NoExt
+type instance XViewPat GhcTc = Type
+
+type instance XSplicePat (GhcPass _) = NoExt
+type instance XLitPat    (GhcPass _) = NoExt
+
+type instance XNPat GhcPs = NoExt
+type instance XNPat GhcRn = NoExt
+type instance XNPat GhcTc = Type
+
+type instance XNPlusKPat GhcPs = NoExt
+type instance XNPlusKPat GhcRn = NoExt
+type instance XNPlusKPat GhcTc = Type
+
+type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
+type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcTc = Type
+
+type instance XCoPat  (GhcPass _) = NoExt
+type instance XXPat   (GhcPass _) = NoExt
+
+-- ---------------------------------------------------------------------
+
 
 -- | Haskell Constructor Pattern Details
 type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
@@ -282,7 +347,6 @@ data HsRecFields p arg         -- A bunch of record fields
   = HsRecFields { rec_flds   :: [LHsRecField p arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
   deriving (Functor, Foldable, Traversable)
-deriving instance (DataId p, Data arg) => Data (HsRecFields p arg)
 
 
 -- Note [DotDot fields]
@@ -367,11 +431,11 @@ data HsRecField' id arg = HsRecField {
 --
 -- The parsed HsRecUpdField corresponding to the record update will have:
 --
---     hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
+--     hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName
 --
 -- After the renamer, this will become:
 --
---     hsRecFieldLbl = Ambiguous   "x" PlaceHolder :: AmbiguousFieldOcc Name
+--     hsRecFieldLbl = Ambiguous   "x" NoExt :: AmbiguousFieldOcc Name
 --
 -- (note that the Unambiguous constructor is not type-correct here).
 -- The typechecker will determine the particular selector:
@@ -380,24 +444,24 @@ data HsRecField' id arg = HsRecField {
 --
 -- See also Note [Disambiguating record fields] in TcExpr.
 
-hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
+hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]
 hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
 
 -- Probably won't typecheck at once, things have changed :/
 hsRecFieldsArgs :: HsRecFields p arg -> [arg]
 hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
 
-hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
-hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)
+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
 
 hsRecFieldId :: HsRecField GhcTc arg -> Located Id
 hsRecFieldId = hsRecFieldSel
 
-hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
 hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
 
 hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
 
 hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
 hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
@@ -411,8 +475,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
 ************************************************************************
 -}
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (Pat pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
     ppr = pprPat
 
 pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -424,46 +487,49 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
     else
         pprPrefixOcc var
 
-pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
-pprParendLPat (L _ p) = pprParendPat p
+pprParendLPat :: (OutputableBndrId (GhcPass p))
+              => PprPrec -> LPat (GhcPass p) -> SDoc
+pprParendLPat p (L _ pat) = pprParendPat p pat
 
-pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprParendPat p = sdocWithDynFlags $ \ dflags ->
-                 if need_parens dflags p
-                 then parens (pprPat p)
-                 else  pprPat p
+pprParendPat :: (OutputableBndrId (GhcPass p))
+             => PprPrec -> Pat (GhcPass p) -> SDoc
+pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
+                     if need_parens dflags pat
+                     then parens (pprPat pat)
+                     else  pprPat pat
   where
-    need_parens dflags p
-      | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags
-      | otherwise     = hsPatNeedsParens p
+    need_parens dflags pat
+      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
+      | otherwise       = patNeedsParens p pat
       -- For a CoPat we need parens if we are going to show it, which
       -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
       -- But otherwise the CoPat is discarded, so it
       -- is the pattern inside that matters.  Sigh.
 
-pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
-pprPat (VarPat (L _ var))     = pprPatBndr var
-pprPat (WildPat _)            = char '_'
-pprPat (LazyPat pat)          = char '~' <> pprParendLPat pat
-pprPat (BangPat pat)          = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat)       = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _)   = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat)           = parens (ppr pat)
-pprPat (LitPat s)             = ppr s
-pprPat (NPat l Nothing  _ _)  = ppr l
-pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice)     = pprSplice splice
-pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens
-                                                            then pprParendPat pat
-                                                            else pprPat pat)
-pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
-pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
-pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
-pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
+pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
+pprPat (VarPat _ (L _ var))     = pprPatBndr var
+pprPat (WildPat _)              = char '_'
+pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
+pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
+pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
+                                        pprParendLPat appPrec pat]
+pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat _ pat)           = parens (ppr pat)
+pprPat (LitPat _ s)             = ppr s
+pprPat (NPat _ l Nothing  _)    = ppr l
+pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l
+pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]
+pprPat (SplicePat _ splice)     = pprSplice splice
+pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
+                                            -> if parens
+                                                 then pprParendPat appPrec pat
+                                                 else pprPat pat
+pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
+pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
+pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
+                                              (pprWithCommas ppr pats)
+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
+pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                     pat_binds = binds, pat_args = details })
   = sdocWithDynFlags $ \dflags ->
@@ -476,16 +542,19 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
+pprPat (XPat x)               = ppr x
 
 
-pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
-           => con -> HsConPatDetails p -> SDoc
+pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
+           => con -> HsConPatDetails (GhcPass p) -> SDoc
 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
 pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
 
-pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
-pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
-pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
+pprConArgs :: (OutputableBndrId (GhcPass p))
+           => HsConPatDetails (GhcPass p) -> SDoc
+pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
+pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
+                                  , pprParendLPat appPrec p2 ]
 pprConArgs (RecCon rpats)   = ppr rpats
 
 instance (Outputable arg)
@@ -495,7 +564,7 @@ instance (Outputable arg)
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
         = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
         where
-          dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))
+          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))
 
 instance (Outputable p, Outputable arg)
       => Outputable (HsRecField' p arg) where
@@ -522,9 +591,9 @@ mkPrefixConPat dc pats tys
 mkNilPat :: Type -> OutPat p
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
-mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
+mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
 mkCharLitPat src c = mkPrefixConPat charDataCon
-                          [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
+                          [noLoc $ LitPat NoExt (HsCharPrim src c)] []
 
 {-
 ************************************************************************
@@ -558,12 +627,8 @@ patterns are treated specially, of course.
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
-isBangedPatBind :: HsBind p -> Bool
-isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
-isBangedPatBind _ = False
-
 isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat p))   = isBangedLPat p
+isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
 isBangedLPat (L _ (BangPat {})) = True
 isBangedLPat _                  = False
 
@@ -577,20 +642,18 @@ looksLazyPatBind (PatBind { pat_lhs = p })
   = looksLazyLPat p
 looksLazyPatBind (AbsBinds { abs_binds = binds })
   = anyBag (looksLazyPatBind . unLoc) binds
-looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })
-  = looksLazyPatBind bind
 looksLazyPatBind _
   = False
 
 looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
+looksLazyLPat (L _ (ParPat _ p))           = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ _ p))          = looksLazyLPat p
 looksLazyLPat (L _ (BangPat {}))           = False
 looksLazyLPat (L _ (VarPat {}))            = False
 looksLazyLPat (L _ (WildPat {}))           = False
 looksLazyLPat _                            = True
 
-isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool
+isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
@@ -611,17 +674,16 @@ isIrrefutableHsPat pat
     go1 (WildPat {})        = True
     go1 (VarPat {})         = True
     go1 (LazyPat {})        = True
-    go1 (BangPat pat)       = go pat
-    go1 (CoPat _ pat _)     = go1 pat
-    go1 (ParPat pat)        = go pat
-    go1 (AsPat _ pat)       = go pat
-    go1 (ViewPat _ pat _)   = go pat
-    go1 (SigPatIn pat _)    = go pat
-    go1 (SigPatOut pat _)   = go pat
-    go1 (TuplePat pats _ _) = all go pats
-    go1 (SumPat pat _ _  _) = go pat
+    go1 (BangPat _ pat)     = go pat
+    go1 (CoPat _ _ pat _)   = go1 pat
+    go1 (ParPat _ pat)      = go pat
+    go1 (AsPat _ _ pat)     = go pat
+    go1 (ViewPat _ _ pat)   = go pat
+    go1 (SigPat _ pat)      = go pat
+    go1 (TuplePat _ pats _) = all go pats
+    go1 (SumPat {})         = False
+                    -- See Note [Unboxed sum patterns aren't irrefutable]
     go1 (ListPat {})        = False
-    go1 (PArrPat {})        = False     -- ?
 
     go1 (ConPatIn {})       = False     -- Conservative
     go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
@@ -640,62 +702,98 @@ isIrrefutableHsPat pat
     -- since we cannot know until the splice is evaluated.
     go1 (SplicePat {})      = False
 
-hsPatNeedsParens :: Pat a -> Bool
-hsPatNeedsParens (NPlusKPat {})      = True
-hsPatNeedsParens (SplicePat {})      = False
-hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
-hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPatIn {})       = True
-hsPatNeedsParens (SigPatOut {})      = True
-hsPatNeedsParens (ViewPat {})        = True
-hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
-hsPatNeedsParens (WildPat {})        = False
-hsPatNeedsParens (VarPat {})         = False
-hsPatNeedsParens (LazyPat {})        = False
-hsPatNeedsParens (BangPat {})        = False
-hsPatNeedsParens (ParPat {})         = False
-hsPatNeedsParens (AsPat {})          = False
-hsPatNeedsParens (TuplePat {})       = False
-hsPatNeedsParens (SumPat {})         = False
-hsPatNeedsParens (ListPat {})        = False
-hsPatNeedsParens (PArrPat {})        = False
-hsPatNeedsParens (LitPat {})         = False
-hsPatNeedsParens (NPat {})           = False
-
-conPatNeedsParens :: HsConDetails a b -> Bool
-conPatNeedsParens (PrefixCon {}) = False
-conPatNeedsParens (InfixCon {})  = True
-conPatNeedsParens (RecCon {})    = False
+    go1 (XPat {})           = False
+
+{- Note [Unboxed sum patterns aren't irrefutable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
+patterns. A simple example that demonstrates this is from #14228:
+
+  pattern Just' x = (# x | #)
+  pattern Nothing' = (# | () #)
+
+  foo x = case x of
+    Nothing' -> putStrLn "nothing"
+    Just'    -> putStrLn "just"
+
+In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,
+as does not match an unboxed sum value of the same arity—namely, (# | y #)
+(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the
+minimum unboxed sum arity is 2.
+
+Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'
+case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
+is the only thing that could possibly be matched!
+-}
+
+-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
+-- parentheses under precedence @p@.
+patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens p = go
+  where
+    go (NPlusKPat {})         = p > opPrec
+    go (SplicePat {})         = False
+    go (ConPatIn _ ds)        = conPatNeedsParens p ds
+    go cp@(ConPatOut {})      = conPatNeedsParens p (pat_args cp)
+    go (SigPat {})            = p > topPrec
+    go (ViewPat {})           = True
+    go (CoPat _ _ p _)        = go p
+    go (WildPat {})           = False
+    go (VarPat {})            = False
+    go (LazyPat {})           = False
+    go (BangPat {})           = False
+    go (ParPat {})            = False
+    go (AsPat {})             = False
+    go (TuplePat {})          = False
+    go (SumPat {})            = False
+    go (ListPat {})           = False
+    go (LitPat _ l)           = hsLitNeedsParens p l
+    go (NPat _ (L _ ol) _ _)  = hsOverLitNeedsParens p ol
+    go (XPat {})              = True -- conservative default
+
+-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
+-- needs parentheses under precedence @p@.
+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
+conPatNeedsParens p = go
+  where
+    go (PrefixCon args) = p >= appPrec && not (null args)
+    go (InfixCon {})    = p >= opPrec
+    go (RecCon {})      = False
+
+-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
+-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
+parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
+parenthesizePat p lpat@(L loc pat)
+  | patNeedsParens p pat = L loc (ParPat NoExt lpat)
+  | otherwise            = lpat
 
 {-
 % Collect all EvVars from all constructor patterns
 -}
 
 -- May need to add more cases
-collectEvVarsPats :: [Pat p] -> Bag EvVar
+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
 collectEvVarsPats = unionManyBags . map collectEvVarsPat
 
-collectEvVarsLPat :: LPat p -> Bag EvVar
+collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
 collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
 
-collectEvVarsPat :: Pat p -> Bag EvVar
+collectEvVarsPat :: Pat GhcTc -> Bag EvVar
 collectEvVarsPat pat =
   case pat of
-    LazyPat  p        -> collectEvVarsLPat p
-    AsPat _  p        -> collectEvVarsLPat p
-    ParPat   p        -> collectEvVarsLPat p
-    BangPat  p        -> collectEvVarsLPat p
-    ListPat  ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
-    TuplePat ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
-    SumPat p _ _ _    -> collectEvVarsLPat p
-    PArrPat  ps _     -> unionManyBags $ map collectEvVarsLPat ps
+    LazyPat _ p      -> collectEvVarsLPat p
+    AsPat _ _ p      -> collectEvVarsLPat p
+    ParPat  _ p      -> collectEvVarsLPat p
+    BangPat _ p      -> collectEvVarsLPat p
+    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
+    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
+    SumPat _ p _ _   -> collectEvVarsLPat p
     ConPatOut {pat_dicts = dicts, pat_args  = args}
-                      -> unionBags (listToBag dicts)
+                     -> unionBags (listToBag dicts)
                                    $ unionManyBags
                                    $ map collectEvVarsLPat
                                    $ hsConPatArgs args
-    SigPatOut p _     -> collectEvVarsLPat p
-    CoPat _ p _       -> collectEvVarsPat  p
-    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"
-    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"
-    _other_pat        -> emptyBag
+    SigPat  _ p      -> collectEvVarsLPat p
+    CoPat _ _ p _    -> collectEvVarsPat  p
+    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
+    _other_pat       -> emptyBag
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 8cb82ed22e..b7efb1c28c 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -4,17 +4,16 @@
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsPat where
 import SrcLoc( Located )
 
-import Data.Data hiding (Fixity)
 import Outputable
-import HsExtension      ( SourceTextX, DataId, OutputableBndrId )
+import HsExtension      ( OutputableBndrId, GhcPass )
 
 type role Pat nominal
 data Pat (i :: *)
 type LPat i = Located (Pat i)
 
-instance (DataId p) => Data (Pat p)
-instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 76afa8b81e..e04abbf70f 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -15,6 +15,8 @@ therefore, is almost nothing but re-exporting.
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
 
 module HsSyn (
         module HsBinds,
@@ -30,10 +32,12 @@ module HsSyn (
         module HsExtension,
         Fixity,
 
-        HsModule(..)
+        HsModule(..),
 ) where
 
 -- friends:
+import GhcPrelude
+
 import HsDecls
 import HsBinds
 import HsExpr
@@ -46,6 +50,7 @@ import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
+import HsInstances ()
 
 -- others:
 import Outputable
@@ -58,12 +63,12 @@ import Data.Data hiding ( Fixity )
 -- | Haskell Module
 --
 -- All we actually declare here is the top-level structure for a module.
-data HsModule name
+data HsModule pass
   = HsModule {
       hsmodName :: Maybe (Located ModuleName),
         -- ^ @Nothing@: \"module X where\" is omitted (in which case the next
         --     field is Nothing too)
-      hsmodExports :: Maybe (Located [LIE name]),
+      hsmodExports :: Maybe (Located [LIE pass]),
         -- ^ Export list
         --
         --  - @Nothing@: export list omitted, so export everything
@@ -77,11 +82,11 @@ data HsModule name
         --                                   ,'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-      hsmodImports :: [LImportDecl name],
+      hsmodImports :: [LImportDecl pass],
         -- ^ We snaffle interesting stuff out of the imported interfaces early
         -- on, adding that info to TyDecls/etc; so this list is often empty,
         -- downstream.
-      hsmodDecls :: [LHsDecl name],
+      hsmodDecls :: [LHsDecl pass],
         -- ^ Type, class, value, and interface signature decls
       hsmodDeprecMessage :: Maybe (Located WarningTxt),
         -- ^ reason\/explanation for warning/deprecation of this module
@@ -108,10 +113,12 @@ data HsModule name
      --    hsmodImports,hsmodDecls if this style is used.
 
      -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (HsModule name)
+-- deriving instance (DataIdLR name name) => Data (HsModule name)
+deriving instance Data (HsModule GhcPs)
+deriving instance Data (HsModule GhcRn)
+deriving instance Data (HsModule GhcTc)
 
-instance (SourceTextX pass, OutputableBndrId pass)
-  => Outputable (HsModule pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
 
     ppr (HsModule Nothing _ imports decls _ mbDoc)
       = pp_mb mbDoc $$ pp_nonnull imports
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 77b1439efb..04260bc0e1 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -8,18 +8,18 @@ HsTypes: Abstract syntax: user-defined types
 
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsTypes (
-        HsType(..), LHsType, HsKind, LHsKind,
+        HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
         HsTyVarBndr(..), LHsTyVarBndr,
-        LHsQTyVars(..),
+        LHsQTyVars(..), HsQTvsRn(..),
         HsImplicitBndrs(..),
         HsWildCardBndrs(..),
         LHsSigType, LHsSigWcType, LHsWcType,
@@ -28,14 +28,13 @@ module HsTypes (
         HsContext, LHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
-        HsAppType(..),LHsAppType,
 
         LBangType, BangType,
         HsSrcBang(..), HsImplBang(..),
         SrcStrictness(..), SrcUnpackedness(..),
         getBangType, getBangStrictness,
 
-        ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
+        ConDeclField(..), LConDeclField, pprConDeclFields,
 
         HsConDetails(..),
 
@@ -44,34 +43,37 @@ module HsTypes (
         rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
         unambiguousFieldOcc, ambiguousFieldOcc,
 
-        HsWildCardInfo(..), mkAnonWildCardTy,
+        HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
         wildCardName, sameWildCard,
 
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
         mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
-        isHsKindedTyVar, hsTvbAllKinded,
+        isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,
         hsScopedTvs, hsWcScopedTvs, dropWildCards,
         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
         hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
         splitLHsPatSynTy,
         splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
-        splitHsFunType, splitHsAppsTy,
-        splitHsAppTys, getAppsTyHead_maybe, hsTyGetAppHead_maybe,
+        splitHsFunType,
+        splitHsAppTys, hsTyGetAppHead_maybe,
         mkHsOpTy, mkHsAppTy, mkHsAppTys,
         ignoreParens, hsSigType, hsSigWcType,
         hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
 
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
-        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
+        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
+        hsTypeNeedsParens, parenthesizeHsType
     ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import PlaceHolder ( PlaceHolder(..) )
 import HsExtension
+import HsLit () -- for instances
 
 import Id ( Id )
 import Name( Name )
@@ -89,8 +91,8 @@ import FastString
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
+import Data.List ( foldl' )
 import Data.Maybe ( fromMaybe )
-import Control.Monad ( unless )
 
 {-
 ************************************************************************
@@ -107,11 +109,11 @@ type LBangType pass = Located (BangType pass)
 type BangType pass  = HsType pass       -- Bangs are in the HsType data type
 
 getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ ty)) = ty
-getBangType ty                    = ty
+getBangType (L _ (HsBangTy _ _ ty)) = ty
+getBangType ty                      = ty
 
 getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness (L _ (HsBangTy _ s _)) = s
 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
@@ -216,6 +218,49 @@ Note carefully:
 * After type checking is done, we report what types the wildcards
   got unified with.
 
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+  const :: a -> b -> a       -- forall a b. ...
+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included
+
+  type a <-< b = b -> a
+  g :: a <-< b               -- forall a b. ...  type synonyms matter
+
+  class Functor f where
+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
+    -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does a *stable topological sort* on the variables.
+By "stable", we mean that any two variables who do not depend on each other
+preserve their existing left-to-right ordering.
+
+Implicitly bound variables are collected by the extract- family of functions
+(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes.
+These functions thus promise to keep left-to-right ordering.
+Look for pointers to this note to see the places where the action happens.
+
+Note that we also maintain this ordering in kind signatures. Even though
+there's no visible kind application (yet), having implicit variables be
+quantified in left-to-right order in kind signatures is nice since:
+
+* It's consistent with the treatment for type signatures.
+* It can affect how types are displayed with -fprint-explicit-kinds (see
+  #15568 for an example), which is a situation where knowing the order in
+  which implicit variables are quantified can be useful.
+* In the event that visible kind application is implemented, the order in
+  which we would expect implicit variables to be ordered in kinds will have
+  already been established.
 -}
 
 -- | Located Haskell Context
@@ -253,65 +298,89 @@ type LHsTyVarBndr pass = Located (HsTyVarBndr pass)
 
 -- | Located Haskell Quantified Type Variables
 data LHsQTyVars pass   -- See Note [HsType binders]
-  = HsQTvs { hsq_implicit :: PostRn pass [Name]
-                                               -- implicit (dependent) variables
-           , hsq_explicit :: [LHsTyVarBndr pass]   -- explicit variables
-             -- See Note [HsForAllTy tyvar binders]
-           , hsq_dependent :: PostRn pass NameSet
-               -- which explicit vars are dependent
-               -- See Note [Dependent LHsQTyVars] in TcHsType
+  = HsQTvs { hsq_ext :: XHsQTvs pass
+
+           , hsq_explicit :: [LHsTyVarBndr pass]
+                -- Explicit variables, written by the user
+                -- See Note [HsForAllTy tyvar binders]
     }
+  | XLHsQTyVars (XXLHsQTyVars pass)
 
-deriving instance (DataId pass) => Data (LHsQTyVars pass)
+data HsQTvsRn
+  = HsQTvsRn
+           { hsq_implicit :: [Name]
+                -- Implicit (dependent) variables
+
+           , hsq_dependent :: NameSet
+               -- Which members of hsq_explicit are dependent; that is,
+               -- mentioned in the kind of a later hsq_explicit,
+               -- or mentioned in a kind in the scope of this HsQTvs
+               -- See Note [Dependent LHsQTyVars] in TcHsType
+           } deriving Data
+
+type instance XHsQTvs       GhcPs = NoExt
+type instance XHsQTvs       GhcRn = HsQTvsRn
+type instance XHsQTvs       GhcTc = HsQTvsRn
+
+type instance XXLHsQTyVars  (GhcPass _) = NoExt
 
 mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
-mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
-                      , hsq_dependent = PlaceHolder }
+mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs }
 
 hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
 hsQTvExplicit = hsq_explicit
 
 emptyLHsQTvs :: LHsQTyVars GhcRn
-emptyLHsQTvs = HsQTvs [] [] emptyNameSet
+emptyLHsQTvs = HsQTvs (HsQTvsRn [] emptyNameSet) []
 
 isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool
-isEmptyLHsQTvs (HsQTvs [] [] _) = True
+isEmptyLHsQTvs (HsQTvs (HsQTvsRn [] _) []) = True
 isEmptyLHsQTvs _                = False
 
 ------------------------------------------------
 --            HsImplicitBndrs
--- Used to quantify the binders of a type in cases
--- when a HsForAll isn't appropriate:
+-- Used to quantify the implicit binders of a type
+--    * Implicit binders of a type signature (LHsSigType/LHsSigWcType)
 --    * Patterns in a type/data family instance (HsTyPats)
---    * Type of a rule binder (RuleBndr)
---    * Pattern type signatures (SigPatIn)
--- In the last of these, wildcards can happen, so we must accommodate them
 
 -- | Haskell Implicit Binders
 data HsImplicitBndrs pass thing   -- See Note [HsType binders]
-  = HsIB { hsib_vars :: PostRn pass [Name] -- Implicitly-bound kind & type vars
-         , hsib_body :: thing              -- Main payload (type or list of types)
-         , hsib_closed :: PostRn pass Bool -- Taking the hsib_vars into account,
-                                           -- is the payload closed? Used in
-                                           -- TcHsType.decideKindGeneralisationPlan
+  = HsIB { hsib_ext  :: XHsIB pass thing -- after renamer: [Name]
+                                         -- Implicitly-bound kind & type vars
+                                         -- Order is important; see
+                                         -- Note [Ordering of implicit variables]
+                                         -- in RnTypes
+
+         , hsib_body :: thing            -- Main payload (type or list of types)
     }
-deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing)
+  | XHsImplicitBndrs (XXHsImplicitBndrs pass thing)
+
+type instance XHsIB              GhcPs _ = NoExt
+type instance XHsIB              GhcRn _ = [Name]
+type instance XHsIB              GhcTc _ = [Name]
+
+type instance XXHsImplicitBndrs  (GhcPass _) _ = NoExt
 
 -- | Haskell Wildcard Binders
 data HsWildCardBndrs pass thing
     -- See Note [HsType binders]
     -- See Note [The wildcard story for types]
-  = HsWC { hswc_wcs :: PostRn pass [Name]
-                -- Wild cards, both named and anonymous
+  = HsWC { hswc_ext :: XHsWC pass thing
                 -- after the renamer
+                -- Wild cards, both named and anonymous
 
          , hswc_body :: thing
                 -- Main payload (type or list of types)
                 -- If there is an extra-constraints wildcard,
                 -- it's still there in the hsc_body.
     }
+  | XHsWildCardBndrs (XXHsWildCardBndrs pass thing)
 
-deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing)
+type instance XHsWC              GhcPs b = NoExt
+type instance XHsWC              GhcRn b = [Name]
+type instance XHsWC              GhcTc b = [Name]
+
+type instance XXHsWildCardBndrs  (GhcPass _) b = NoExt
 
 -- | Located Haskell Signature Type
 type LHsSigType   pass = HsImplicitBndrs pass (LHsType pass)    -- Implicit only
@@ -326,6 +395,7 @@ type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
 
 hsImplicitBody :: HsImplicitBndrs pass thing -> thing
 hsImplicitBody (HsIB { hsib_body = body }) = body
+hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody"
 
 hsSigType :: LHsSigType pass -> LHsType pass
 hsSigType = hsImplicitBody
@@ -358,24 +428,22 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
 -}
 
 mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
-mkHsImplicitBndrs x = HsIB { hsib_body   = x
-                           , hsib_vars   = PlaceHolder
-                           , hsib_closed = PlaceHolder }
+mkHsImplicitBndrs x = HsIB { hsib_ext  = noExt
+                           , hsib_body = x }
 
 mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
 mkHsWildCardBndrs x = HsWC { hswc_body = x
-                           , hswc_wcs  = PlaceHolder }
+                           , hswc_ext  = noExt }
 
 -- Add empty binders.  This is a bit suspicious; what if
 -- the wrapped thing had free type variables?
 mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing
-mkEmptyImplicitBndrs x = HsIB { hsib_body   = x
-                              , hsib_vars   = []
-                              , hsib_closed = False }
+mkEmptyImplicitBndrs x = HsIB { hsib_ext = []
+                              , hsib_body = x }
 
 mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
 mkEmptyWildCardBndrs x = HsWC { hswc_body = x
-                              , hswc_wcs  = [] }
+                              , hswc_ext  = [] }
 
 
 --------------------------------------------------
@@ -400,9 +468,11 @@ instance OutputableBndr HsIPName where
 -- | Haskell Type Variable Binder
 data HsTyVarBndr pass
   = UserTyVar        -- no explicit kinding
+         (XUserTyVar pass)
          (Located (IdP pass))
         -- See Note [Located RdrNames] in HsExpr
   | KindedTyVar
+         (XKindedTyVar pass)
          (Located (IdP pass))
          (LHsKind pass)  -- The user-supplied kind signature
         -- ^
@@ -410,12 +480,19 @@ data HsTyVarBndr pass
         --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsTyVarBndr pass)
+
+  | XTyVarBndr
+      (XXTyVarBndr pass)
+
+type instance XUserTyVar    (GhcPass _) = NoExt
+type instance XKindedTyVar  (GhcPass _) = NoExt
+type instance XXTyVarBndr   (GhcPass _) = NoExt
 
 -- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
 isHsKindedTyVar :: HsTyVarBndr pass -> Bool
 isHsKindedTyVar (UserTyVar {})   = False
 isHsKindedTyVar (KindedTyVar {}) = True
+isHsKindedTyVar (XTyVarBndr{})   = panic "isHsKindedTyVar"
 
 -- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
 hsTvbAllKinded :: LHsQTyVars pass -> Bool
@@ -424,19 +501,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
 -- | Haskell Type
 data HsType pass
   = HsForAllTy   -- See Note [HsType binders]
-      { hst_bndrs :: [LHsTyVarBndr pass]
+      { hst_xforall :: XForAllTy pass,
+        hst_bndrs   :: [LHsTyVarBndr pass]
                                        -- Explicit, user-supplied 'forall a b c'
-      , hst_body  :: LHsType pass      -- body type
+      , hst_body    :: LHsType pass      -- body type
       }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsQualTy   -- See Note [HsType binders]
-      { hst_ctxt :: LHsContext pass       -- Context C => blah
-      , hst_body :: LHsType pass }
+      { hst_xqual :: XQualTy pass
+      , hst_ctxt  :: LHsContext pass       -- Context C => blah
+      , hst_body  :: LHsType pass }
 
-  | HsTyVar             Promoted -- whether explicitly promoted, for the pretty
+  | HsTyVar             (XTyVar pass)
+                        Promoted -- whether explicitly promoted, for the pretty
                                  -- printer
                         (Located (IdP pass))
                   -- Type variable, type constructor, or data constructor
@@ -446,53 +526,50 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsAppsTy            [LHsAppType pass] -- Used only before renaming,
-                                          -- Note [HsAppsTy]
-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
-
-  | HsAppTy             (LHsType pass)
+  | HsAppTy             (XAppTy pass)
+                        (LHsType pass)
                         (LHsType pass)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsFunTy             (LHsType pass)   -- function type
+  | HsFunTy             (XFunTy pass)
+                        (LHsType pass)   -- function type
                         (LHsType pass)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsListTy            (LHsType pass)  -- Element type
+  | HsListTy            (XListTy pass)
+                        (LHsType pass)  -- Element type
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
       --         'ApiAnnotation.AnnClose' @']'@
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsPArrTy            (LHsType pass)  -- Elem. type of parallel array: [:t:]
-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
-      --         'ApiAnnotation.AnnClose' @':]'@
-
-      -- For details on above see note [Api annotations] in ApiAnnotation
-
-  | HsTupleTy           HsTupleSort
+  | HsTupleTy           (XTupleTy pass)
+                        HsTupleSort
                         [LHsType pass]  -- Element types (length gives arity)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,
     --         'ApiAnnotation.AnnClose' @')' or '#)'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsSumTy             [LHsType pass]  -- Element types (length gives arity)
+  | HsSumTy             (XSumTy pass)
+                        [LHsType pass]  -- Element types (length gives arity)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,
     --         'ApiAnnotation.AnnClose' '#)'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsOpTy              (LHsType pass) (Located (IdP pass)) (LHsType pass)
+  | HsOpTy              (XOpTy pass)
+                        (LHsType pass) (Located (IdP pass)) (LHsType pass)
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsParTy             (LHsType pass)   -- See Note [Parens in HsSyn] in HsExpr
+  | HsParTy             (XParTy pass)
+                        (LHsType pass)   -- See Note [Parens in HsSyn] in HsExpr
         -- Parenthesis preserved for the precedence re-arrangement in RnTypes
         -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
@@ -500,7 +577,8 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsIParamTy          (Located HsIPName) -- (?x :: ty)
+  | HsIParamTy          (XIParamTy pass)
+                        (Located HsIPName) -- (?x :: ty)
                         (LHsType pass)   -- Implicit parameters as they occur in
                                          -- contexts
       -- ^
@@ -510,18 +588,13 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsEqTy              (LHsType pass)   -- ty1 ~ ty2
-                        (LHsType pass)   -- Always allowed even without
-                                         -- TypeOperators, and has special
-                                         -- kinding rule
-      -- ^
-      -- > ty1 ~ ty2
-      --
-      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-
-      -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsStarTy            (XStarTy pass)
+                        Bool             -- Is this the Unicode variant?
+                                         -- Note [HsStarTy]
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
-  | HsKindSig           (LHsType pass)  -- (ty :: kind)
+  | HsKindSig           (XKindSig pass)
+                        (LHsType pass)  -- (ty :: kind)
                         (LHsKind pass)  -- A type with a kind signature
       -- ^
       -- > (ty :: kind)
@@ -531,19 +604,21 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsSpliceTy          (HsSplice pass)   -- Includes quasi-quotes
-                        (PostTc pass Kind)
+  | HsSpliceTy          (XSpliceTy pass)
+                        (HsSplice pass)   -- Includes quasi-quotes
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,
       --         'ApiAnnotation.AnnClose' @')'@
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsDocTy             (LHsType pass) LHsDocString -- A documented type
+  | HsDocTy             (XDocTy pass)
+                        (LHsType pass) LHsDocString -- A documented type
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsBangTy    HsSrcBang (LHsType pass)   -- Bang-style type annotations
+  | HsBangTy    (XBangTy pass)
+                HsSrcBang (LHsType pass)   -- Bang-style type annotations
       -- ^ - 'ApiAnnotation.AnnKeywordId' :
       --         'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,
       --         'ApiAnnotation.AnnClose' @'#-}'@
@@ -551,21 +626,22 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsRecTy     [LConDeclField pass]    -- Only in data type declarations
+  | HsRecTy     (XRecTy pass)
+                [LConDeclField pass]    -- Only in data type declarations
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,
       --         'ApiAnnotation.AnnClose' @'}'@
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCoreTy Type       -- An escape hatch for tunnelling a *closed*
-                        -- Core Type through HsSyn.
-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+  -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*
+  --                                -- Core Type through HsSyn.
+  --     -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsExplicitListTy       -- A promoted explicit list
+        (XExplicitListTy pass)
         Promoted           -- whether explcitly promoted, for pretty printer
-        (PostTc pass Kind) -- See Note [Promoted lists and tuples]
         [LHsType pass]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
       --         'ApiAnnotation.AnnClose' @']'@
@@ -573,24 +649,77 @@ data HsType pass
       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsExplicitTupleTy      -- A promoted explicit tuple
-        [PostTc pass Kind] -- See Note [Promoted lists and tuples]
+        (XExplicitTupleTy pass)
         [LHsType pass]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,
       --         'ApiAnnotation.AnnClose' @')'@
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsTyLit HsTyLit      -- A promoted numeric literal.
+  | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsWildCardTy (HsWildCardInfo pass)  -- A type wildcard
+  | HsWildCardTy (XWildCardTy pass)  -- A type wildcard
       -- See Note [The wildcard story for types]
+      -- A anonymous wild card ('_'). A fresh Name is generated for
+      -- each individual anonymous wildcard during renaming
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsType pass)
+
+  -- For adding new constructors via Trees that Grow
+  | XHsType
+      (XXType pass)
+
+data NewHsTypeX
+  = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
+                   -- Core Type through HsSyn.
+    deriving Data
+      -- ^ - 'ApiAnnotation.AnnKeywordId' : None
+
+instance Outputable NewHsTypeX where
+  ppr (NHsCoreTy ty) = ppr ty
+
+type instance XForAllTy        (GhcPass _) = NoExt
+type instance XQualTy          (GhcPass _) = NoExt
+type instance XTyVar           (GhcPass _) = NoExt
+type instance XAppTy           (GhcPass _) = NoExt
+type instance XFunTy           (GhcPass _) = NoExt
+type instance XListTy          (GhcPass _) = NoExt
+type instance XTupleTy         (GhcPass _) = NoExt
+type instance XSumTy           (GhcPass _) = NoExt
+type instance XOpTy            (GhcPass _) = NoExt
+type instance XParTy           (GhcPass _) = NoExt
+type instance XIParamTy        (GhcPass _) = NoExt
+type instance XStarTy          (GhcPass _) = NoExt
+type instance XKindSig         (GhcPass _) = NoExt
+
+type instance XSpliceTy        GhcPs = NoExt
+type instance XSpliceTy        GhcRn = NoExt
+type instance XSpliceTy        GhcTc = Kind
+
+type instance XDocTy           (GhcPass _) = NoExt
+type instance XBangTy          (GhcPass _) = NoExt
+type instance XRecTy           (GhcPass _) = NoExt
+
+type instance XExplicitListTy  GhcPs = NoExt
+type instance XExplicitListTy  GhcRn = NoExt
+type instance XExplicitListTy  GhcTc = Kind
+
+type instance XExplicitTupleTy GhcPs = NoExt
+type instance XExplicitTupleTy GhcRn = NoExt
+type instance XExplicitTupleTy GhcTc = [Kind]
+
+type instance XTyLit           (GhcPass _) = NoExt
+
+type instance XWildCardTy      GhcPs = NoExt
+type instance XWildCardTy      GhcRn = HsWildCardInfo
+type instance XWildCardTy      GhcTc = HsWildCardInfo
+
+type instance XXType         (GhcPass _) = NewHsTypeX
+
 
 -- Note [Literal source text] in BasicTypes for SourceText fields in
 -- the following
@@ -600,25 +729,11 @@ data HsTyLit
   | HsStrTy SourceText FastString
     deriving Data
 
-newtype HsWildCardInfo pass      -- See Note [The wildcard story for types]
-    = AnonWildCard (PostRn pass (Located Name))
+newtype HsWildCardInfo        -- See Note [The wildcard story for types]
+    = AnonWildCard (Located Name)
+      deriving Data
       -- A anonymous wild card ('_'). A fresh Name is generated for
       -- each individual anonymous wildcard during renaming
-deriving instance (DataId pass) => Data (HsWildCardInfo pass)
-
--- | Located Haskell Application Type
-type LHsAppType pass = Located (HsAppType pass)
-      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote'
-
--- | Haskell Application Type
-data HsAppType pass
-  = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks
-  | HsAppPrefix (LHsType pass)      -- anything else, including things like (+)
-deriving instance (DataId pass) => Data (HsAppType pass)
-
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsAppType pass) where
-  ppr = ppr_app_ty
 
 {-
 Note [HsForAllTy tyvar binders]
@@ -675,16 +790,18 @@ HsTyVar: A name in a type or kind.
   The 'Promoted' field in an HsTyVar captures whether the type was promoted in
   the source code by prefixing an apostrophe.
 
-Note [HsAppsTy]
+Note [HsStarTy]
 ~~~~~~~~~~~~~~~
-How to parse
+When the StarIsType extension is enabled, we want to treat '*' and its Unicode
+variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser
+would mean that when we pretty-print it back, we don't know whether the user
+wrote '*' or 'Type', and lose the parse/ppr roundtrip property.
 
-  Foo * Int
+As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')
+and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).
+When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not
+involved.
 
-? Is it `(*) Foo Int` or `Foo GHC.Types.* Int`? There's no way to know until renaming.
-So we just take type expressions like this and put each component in a list, so be
-sorted out in the renamer. The sorting out is done by RnTypes.mkHsOpTyRn. This means
-that the parser should never produce HsAppTy or HsOpTy.
 
 Note [Promoted lists and tuples]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -752,18 +869,23 @@ type LConDeclField pass = Located (ConDeclField pass)
 
 -- | Constructor Declaration Field
 data ConDeclField pass  -- Record fields have Haddoc docs on them
-  = ConDeclField { cd_fld_names :: [LFieldOcc pass],
+  = ConDeclField { cd_fld_ext  :: XConDeclField pass,
+                   cd_fld_names :: [LFieldOcc pass],
                                    -- ^ See Note [ConDeclField passs]
                    cd_fld_type :: LBangType pass,
                    cd_fld_doc  :: Maybe LHsDocString }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (ConDeclField pass)
+  | XConDeclField (XXConDeclField pass)
+
+type instance XConDeclField  (GhcPass _) = NoExt
+type instance XXConDeclField (GhcPass _) = NoExt
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (ConDeclField pass) where
-  ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (ConDeclField p) where
+  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
+  ppr (XConDeclField x) = ppr x
 
 -- HsConDetails is used for patterns/expressions *and* for data type
 -- declarations
@@ -780,30 +902,6 @@ instance (Outputable arg, Outputable rec)
   ppr (RecCon rec)     = text "RecCon:" <+> ppr rec
   ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]
 
--- Takes details and result type of a GADT data constructor as created by the
--- parser and rejigs them using information about fixities from the renamer.
--- See Note [Sorting out the result type] in RdrHsSyn
-updateGadtResult
-  :: (Monad m)
-     => (SDoc -> m ())
-     -> SDoc
-     -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-                     -- ^ Original details
-     -> LHsType GhcRn -- ^ Original result type
-     -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
-           LHsType GhcRn)
-updateGadtResult failWith doc details ty
-  = do { let (arg_tys, res_ty) = splitHsFunType ty
-             badConSig         = text "Malformed constructor signature"
-       ; case details of
-           InfixCon {}  -> pprPanic "updateGadtResult" (ppr ty)
-
-           RecCon {}    -> do { unless (null arg_tys)
-                                       (failWith (doc <+> badConSig))
-                              ; return (details, res_ty) }
-
-           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
-
 {-
 Note [ConDeclField passs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -836,19 +934,23 @@ hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]
 --  - the named wildcars; see Note [Scoping of named wildcards]
 -- because they scope in the same way
 hsWcScopedTvs sig_ty
-  | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 }  <- sig_ty
-  , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
+  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 }  <- sig_ty
+  , HsIB { hsib_ext = vars
+         , hsib_body = sig_ty2 } <- sig_ty1
   = case sig_ty2 of
       L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
                                               map hsLTyVarName tvs
                -- include kind variables only if the type is headed by forall
                -- (this is consistent with GHC 7 behaviour)
       _                                    -> nwcs
+hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs"
+hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs"
 
 hsScopedTvs :: LHsSigType GhcRn -> [Name]
 -- Same as hsWcScopedTvs, but for a LHsSigType
 hsScopedTvs sig_ty
-  | HsIB { hsib_vars = vars,  hsib_body = sig_ty2 } <- sig_ty
+  | HsIB { hsib_ext = vars
+         , hsib_body = sig_ty2 } <- sig_ty
   , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2
   = vars ++ map hsLTyVarName tvs
   | otherwise
@@ -869,8 +971,9 @@ I don't know if this is a good idea, but there it is.
 
 ---------------------
 hsTyVarName :: HsTyVarBndr pass -> IdP pass
-hsTyVarName (UserTyVar (L _ n))     = n
-hsTyVarName (KindedTyVar (L _ n) _) = n
+hsTyVarName (UserTyVar _ (L _ n))     = n
+hsTyVarName (KindedTyVar _ (L _ n) _) = n
+hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName"
 
 hsLTyVarName :: LHsTyVarBndr pass -> IdP pass
 hsLTyVarName = hsTyVarName . unLoc
@@ -881,8 +984,10 @@ hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
 
 hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
 -- All variables
-hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
+hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs }
+                         , hsq_explicit = tvs })
   = kvs ++ map hsLTyVarName tvs
+hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames"
 
 hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass)
 hsLTyVarLocName = fmap hsTyVarName
@@ -891,30 +996,35 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)]
 hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
 
 -- | Convert a LHsTyVarBndr to an equivalent LHsType.
-hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass
+hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
 hsLTyVarBndrToType = fmap cvt
-  where cvt (UserTyVar n) = HsTyVar NotPromoted n
-        cvt (KindedTyVar (L name_loc n) kind)
-          = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
+  where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n
+        cvt (KindedTyVar _ (L name_loc n) kind)
+          = HsKindSig noExt
+                   (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind
+        cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType"
 
 -- | Convert a LHsTyVarBndrs to a list of types.
 -- Works on *type* variable only, no kind vars.
-hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass]
+hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
 hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
+hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes"
 
 ---------------------
-wildCardName :: HsWildCardInfo GhcRn -> Name
+wildCardName :: HsWildCardInfo -> Name
 wildCardName (AnonWildCard  (L _ n)) = n
 
 -- Two wild cards are the same when they have the same location
-sameWildCard :: Located (HsWildCardInfo pass)
-             -> Located (HsWildCardInfo pass) -> Bool
+sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool
 sameWildCard (L l1 (AnonWildCard _))   (L l2 (AnonWildCard _))   = l1 == l2
 
 ignoreParens :: LHsType pass -> LHsType pass
-ignoreParens (L _ (HsParTy ty))                      = ignoreParens ty
-ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
-ignoreParens ty                                      = ty
+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty
+ignoreParens ty                   = ty
+
+isLHsForAllTy :: LHsType p -> Bool
+isLHsForAllTy (L _ (HsForAllTy {})) = True
+isLHsForAllTy _                     = False
 
 {-
 ************************************************************************
@@ -925,17 +1035,19 @@ ignoreParens ty                                      = ty
 -}
 
 mkAnonWildCardTy :: HsType GhcPs
-mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
+mkAnonWildCardTy = HsWildCardTy noExt
 
-mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass
-mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2
+mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))
+         -> LHsType (GhcPass p) -> HsType (GhcPass p)
+mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
 
-mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass
-mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
-
-mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass
-mkHsAppTys = foldl mkHsAppTy
+mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppTy t1 t2
+  = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2))
 
+mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
+           -> LHsType (GhcPass p)
+mkHsAppTys = foldl' mkHsAppTy
 
 {-
 ************************************************************************
@@ -952,79 +1064,46 @@ mkHsAppTys = foldl mkHsAppTy
 -- Also deals with (->) t1 t2; that is why it only works on LHsType Name
 --   (see Trac #9096)
 splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)
-splitHsFunType (L _ (HsParTy ty))
+splitHsFunType (L _ (HsParTy _ ty))
   = splitHsFunType ty
 
-splitHsFunType (L _ (HsFunTy x y))
+splitHsFunType (L _ (HsFunTy _ x y))
   | (args, res) <- splitHsFunType y
   = (x:args, res)
 
-splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
+splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))
   = go t1 [t2]
   where  -- Look for (->) t1 t2, possibly with parenthesisation
-    go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName
+    go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName
                                  , [t1,t2] <- tys
                                  , (args, res) <- splitHsFunType t2
                                  = (t1:args, res)
-    go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
-    go (L _ (HsParTy ty))    tys = go ty tys
-    go _                     _   = ([], orig_ty)  -- Failure to match
+    go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)
+    go (L _ (HsParTy _ ty))    tys = go ty tys
+    go _                       _   = ([], orig_ty)  -- Failure to match
 
 splitHsFunType other = ([], other)
 
---------------------------------
--- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
--- without consulting fixities.
-getAppsTyHead_maybe :: [LHsAppType pass]
-                    -> Maybe (LHsType pass, [LHsType pass], LexicalFixity)
-getAppsTyHead_maybe tys = case splitHsAppsTy tys of
-  ([app1:apps], []) ->  -- no symbols, some normal types
-    Just (mkHsAppTys app1 apps, [], Prefix)
-  ([app1l:appsl, app1r:appsr], [L loc op]) ->  -- one operator
-    Just ( L loc (HsTyVar NotPromoted (L loc op))
-         , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix)
-  _ -> -- can't figure it out
-    Nothing
-
--- | Splits a [HsAppType pass] (the payload of an HsAppsTy) into regions of
--- prefix types (normal types) and infix operators.
--- If @splitHsAppsTy tys = (non_syms, syms)@, then @tys@ starts with the first
--- element of @non_syms@ followed by the first element of @syms@ followed by
--- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
--- has one more element than the syms list.
-splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)])
-splitHsAppsTy = go [] [] []
-  where
-    go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
-    go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
-      = go (ty : acc) acc_non acc_sym rest
-    go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
-      = go [] (reverse acc : acc_non) (op : acc_sym) rest
-
--- Retrieve the name of the "head" of a nested type application
+-- retrieve the name of the "head" of a nested type application
 -- somewhat like splitHsAppTys, but a little more thorough
 -- used to examine the result of a GADT-like datacon, so it doesn't handle
 -- *all* cases (like lists, tuples, (~), etc.)
-hsTyGetAppHead_maybe :: LHsType pass
-                     -> Maybe (Located (IdP pass), [LHsType pass])
+hsTyGetAppHead_maybe :: LHsType (GhcPass p)
+                     -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)])
 hsTyGetAppHead_maybe = go []
   where
-    go tys (L _ (HsTyVar _ ln))          = Just (ln, tys)
-    go tys (L _ (HsAppsTy apps))
-      | Just (head, args, _) <- getAppsTyHead_maybe apps
-                                         = go (args ++ tys) head
-    go tys (L _ (HsAppTy l r))           = go (r : tys) l
-    go tys (L _ (HsOpTy l (L loc n) r))  = Just (L loc n, l : r : tys)
-    go tys (L _ (HsParTy t))             = go tys t
-    go tys (L _ (HsKindSig t _))         = go tys t
+    go tys (L _ (HsTyVar _ _ ln))          = Just (ln, tys)
+    go tys (L _ (HsAppTy _ l r))           = go (r : tys) l
+    go tys (L _ (HsOpTy _ l (L loc n) r))  = Just (L loc n, l : r : tys)
+    go tys (L _ (HsParTy _ t))             = go tys t
+    go tys (L _ (HsKindSig _ t _))         = go tys t
     go _   _                             = Nothing
 
 splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn]
               -> (LHsType GhcRn, [LHsType GhcRn])
-  -- no need to worry about HsAppsTy here
-splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
-splitHsAppTys (L _ (HsParTy f))   as = splitHsAppTys f as
-splitHsAppTys f                   as = (f,as)
+splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys (L _ (HsParTy _ f))   as = splitHsAppTys f as
+splitHsAppTys f                     as = (f,as)
 
 --------------------------------
 splitLHsPatSynTy :: LHsType pass
@@ -1048,29 +1127,33 @@ splitLHsSigmaTy ty
   = (tvs, ctxt, ty2)
 
 splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)
+splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty
 splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body)
-splitLHsForAllTy body                                                    = ([], body)
+splitLHsForAllTy body              = ([], body)
 
 splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
+splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
 splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt,     body)
-splitLHsQualTy body                                                  = (noLoc [], body)
+splitLHsQualTy body              = (noLoc [], body)
 
 splitLHsInstDeclTy :: LHsSigType GhcRn
                    -> ([Name], LHsContext GhcRn, LHsType GhcRn)
 -- Split up an instance decl type, returning the pieces
-splitLHsInstDeclTy (HsIB { hsib_vars = itkvs
+splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
                          , hsib_body = inst_ty })
   | (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty
   = (itkvs ++ map hsLTyVarName tvs, cxt, body_ty)
          -- Return implicitly bound type and kind vars
          -- For an instance decl, all of them are in scope
+splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy"
 
 getLHsInstDeclHead :: LHsSigType pass -> LHsType pass
 getLHsInstDeclHead inst_ty
   | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty)
   = body_ty
 
-getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass))
+getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)
+                          -> Maybe (Located (IdP (GhcPass p)))
 -- Works on (HsSigType RdrName)
 getLHsInstDeclClass_maybe inst_ty
   = do { let head_ty = getLHsInstDeclHead inst_ty
@@ -1093,19 +1176,27 @@ type LFieldOcc pass = Located (FieldOcc pass)
 -- Represents an *occurrence* of an unambiguous field.  We store
 -- both the 'RdrName' the user originally wrote, and after the
 -- renamer, the selector function.
-data FieldOcc pass = FieldOcc { rdrNameFieldOcc  :: Located RdrName
+data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass
+                              , rdrNameFieldOcc :: Located RdrName
                                  -- ^ See Note [Located RdrNames] in HsExpr
-                              , selectorFieldOcc :: PostRn pass (IdP pass)
                               }
-deriving instance Eq (PostRn pass (IdP pass))  => Eq  (FieldOcc pass)
-deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass)
-deriving instance (DataId pass) => Data (FieldOcc pass)
+
+  | XFieldOcc
+      (XXFieldOcc pass)
+deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq  (FieldOcc p)
+deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p)
+
+type instance XCFieldOcc GhcPs = NoExt
+type instance XCFieldOcc GhcRn = Name
+type instance XCFieldOcc GhcTc = Id
+
+type instance XXFieldOcc (GhcPass _) = NoExt
 
 instance Outputable (FieldOcc pass) where
   ppr = ppr . rdrNameFieldOcc
 
 mkFieldOcc :: Located RdrName -> FieldOcc GhcPs
-mkFieldOcc rdr = FieldOcc rdr PlaceHolder
+mkFieldOcc rdr = FieldOcc noExt rdr
 
 
 -- | Ambiguous Field Occurrence
@@ -1121,37 +1212,50 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
 -- Note [Disambiguating record fields] in TcExpr.
 -- See Note [Located RdrNames] in HsExpr
 data AmbiguousFieldOcc pass
-  = Unambiguous (Located RdrName) (PostRn pass (IdP pass))
-  | Ambiguous   (Located RdrName) (PostTc pass (IdP pass))
-deriving instance ( Data pass
-                  , Data (PostTc pass (IdP pass))
-                  , Data (PostRn pass (IdP pass)))
-                  => Data (AmbiguousFieldOcc pass)
-
-instance Outputable (AmbiguousFieldOcc pass) where
+  = Unambiguous (XUnambiguous pass) (Located RdrName)
+  | Ambiguous   (XAmbiguous pass)   (Located RdrName)
+  | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
+
+type instance XUnambiguous GhcPs = NoExt
+type instance XUnambiguous GhcRn = Name
+type instance XUnambiguous GhcTc = Id
+
+type instance XAmbiguous GhcPs = NoExt
+type instance XAmbiguous GhcRn = NoExt
+type instance XAmbiguous GhcTc = Id
+
+type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt
+
+instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
   ppr = ppr . rdrNameAmbiguousFieldOcc
 
-instance OutputableBndr (AmbiguousFieldOcc pass) where
+instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where
   pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc
   pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
 
 mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs
-mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
+mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr
 
-rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName
-rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr
-rdrNameAmbiguousFieldOcc (Ambiguous   (L _ rdr) _) = rdr
+rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
+rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr
+rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+  = panic "rdrNameAmbiguousFieldOcc"
 
 selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
-selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel
-selectorAmbiguousFieldOcc (Ambiguous   _ sel) = sel
+selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
+selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel
+selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _)
+  = panic "selectorAmbiguousFieldOcc"
 
 unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
 unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
 unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel
+unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc"
 
-ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass
-ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
+ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
+ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
+ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc"
 
 {-
 ************************************************************************
@@ -1161,33 +1265,41 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
 ************************************************************************
 -}
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsType pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
     ppr ty = pprHsType ty
 
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (LHsQTyVars pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (LHsQTyVars p) where
     ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
+    ppr (XLHsQTyVars x) = ppr x
 
-instance (SourceTextX pass, OutputableBndrId pass)
-       => Outputable (HsTyVarBndr pass) where
-    ppr (UserTyVar n)     = ppr n
-    ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
+instance (p ~ GhcPass pass, OutputableBndrId p)
+       => Outputable (HsTyVarBndr p) where
+    ppr (UserTyVar _ n)     = ppr n
+    ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
+    ppr (XTyVarBndr n)      = ppr n
 
-instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where
+instance (p ~ GhcPass pass,Outputable thing)
+       => Outputable (HsImplicitBndrs p thing) where
     ppr (HsIB { hsib_body = ty }) = ppr ty
+    ppr (XHsImplicitBndrs x) = ppr x
 
-instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
+instance (p ~ GhcPass pass,Outputable thing)
+       => Outputable (HsWildCardBndrs p thing) where
     ppr (HsWC { hswc_body = ty }) = ppr ty
+    ppr (XHsWildCardBndrs x) = ppr x
 
-instance Outputable (HsWildCardInfo pass) where
+instance Outputable HsWildCardInfo where
     ppr (AnonWildCard _)  = char '_'
 
-pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
-            => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
+pprAnonWildCard :: SDoc
+pprAnonWildCard = char '_'
+
+pprHsForAll :: (OutputableBndrId (GhcPass p))
+            => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
 pprHsForAll = pprHsForAllExtra Nothing
 
 -- | Version of 'pprHsForAll' that can also print an extra-constraints
@@ -1197,43 +1309,43 @@ pprHsForAll = pprHsForAllExtra Nothing
 -- function for this is needed, as the extra-constraints wildcard is removed
 -- from the actual context and type, and stored in a separate field, thus just
 -- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass)
-                 => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
-                 -> SDoc
+pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
+                 => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
+                 -> LHsContext (GhcPass p) -> SDoc
 pprHsForAllExtra extra qtvs cxt
   = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
   where
     show_extra = isJust extra
 
-pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
-               => [LHsTyVarBndr pass] -> SDoc
-pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug ->
-  ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot
+pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
+               => [LHsTyVarBndr (GhcPass p)] -> SDoc
+pprHsForAllTvs qtvs
+  | null qtvs = whenPprDebug (forAllLit <+> dot)
+  | otherwise = forAllLit <+> interppSP qtvs <> dot
 
-pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
-             => HsContext pass -> SDoc
+pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
 pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
 
-pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
-                    => HsContext pass -> SDoc
+pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
+                    => HsContext (GhcPass p) -> SDoc
 pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
 
-pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
-                  => HsContext pass -> Maybe SDoc
+pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
+                  => HsContext (GhcPass p) -> Maybe SDoc
 pprHsContextMaybe []         = Nothing
 pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
 pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
 
 -- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
-                   => HsContext pass -> SDoc
+pprHsContextAlways :: (OutputableBndrId (GhcPass p))
+                   => HsContext (GhcPass p) -> SDoc
 pprHsContextAlways []  = parens empty <+> darrow
 pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
 pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
 
 -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
-                  => Bool -> HsContext pass -> SDoc
+pprHsContextExtra :: (OutputableBndrId (GhcPass p))
+                  => Bool -> HsContext (GhcPass p) -> SDoc
 pprHsContextExtra show_extra ctxt
   | not show_extra
   = pprHsContext ctxt
@@ -1244,13 +1356,14 @@ pprHsContextExtra show_extra ctxt
   where
     ctxt' = map ppr ctxt ++ [char '_']
 
-pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
-                 => [LConDeclField pass] -> SDoc
+pprConDeclFields :: (OutputableBndrId (GhcPass p))
+                 => [LConDeclField (GhcPass p)] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
     ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
                                  cd_fld_doc = doc }))
         = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
+    ppr_fld (L _ (XConDeclField x)) = ppr x
     ppr_names [n] = ppr n
     ppr_names ns = sep (punctuate comma (map ppr ns))
 
@@ -1269,76 +1382,72 @@ seems like the Right Thing anyway.)
 
 -- Printing works more-or-less as for Types
 
-pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
+pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
 pprHsType ty = ppr_mono_ty ty
 
-ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
-             => LHsType pass -> SDoc
+ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
 ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
-ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
-            => HsType pass -> SDoc
+ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
 ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
   = sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
 
 ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
   = sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
 
-ppr_mono_ty (HsBangTy b ty)     = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy flds)      = pprConDeclFields flds
-ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
-ppr_mono_ty (HsTyVar Promoted (L _ name))
+ppr_mono_ty (HsBangTy _ b ty)   = ppr b <> ppr_mono_lty ty
+ppr_mono_ty (HsRecTy _ flds)      = pprConDeclFields flds
+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
+ppr_mono_ty (HsTyVar _ Promoted (L _ name))
   = space <> quote (pprPrefixOcc name)
                          -- We need a space before the ' above, so the parser
                          -- does not attach it to the previous symbol
-ppr_mono_ty (HsFunTy ty1 ty2)   = ppr_fun_ty ty1 ty2
-ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
+ppr_mono_ty (HsFunTy _ ty1 ty2)   = ppr_fun_ty ty1 ty2
+ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
   where std_con = case con of
                     HsUnboxedTuple -> UnboxedTuple
                     _              -> BoxedTuple
-ppr_mono_ty (HsSumTy tys)       = tupleParens UnboxedTuple (pprWithBars ppr tys)
-ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
-ppr_mono_ty (HsListTy ty)       = brackets (ppr_mono_lty ty)
-ppr_mono_ty (HsPArrTy ty)       = paBrackets (ppr_mono_lty ty)
-ppr_mono_ty (HsIParamTy n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)
-ppr_mono_ty (HsSpliceTy s _)    = pprSplice s
-ppr_mono_ty (HsCoreTy ty)       = ppr ty
-ppr_mono_ty (HsExplicitListTy Promoted _ tys)
+ppr_mono_ty (HsSumTy _ tys)
+  = tupleParens UnboxedTuple (pprWithBars ppr tys)
+ppr_mono_ty (HsKindSig _ ty kind)
+  = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind)
+ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)
+ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)
+ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s
+ppr_mono_ty (HsExplicitListTy _ Promoted tys)
   = quote $ brackets (interpp'SP tys)
-ppr_mono_ty (HsExplicitListTy NotPromoted _ tys)
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
   = brackets (interpp'SP tys)
 ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
-ppr_mono_ty (HsTyLit t)         = ppr_tylit t
+ppr_mono_ty (HsTyLit _ t)       = ppr_tylit t
 ppr_mono_ty (HsWildCardTy {})   = char '_'
 
-ppr_mono_ty (HsEqTy ty1 ty2)
-  = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2
-
-ppr_mono_ty (HsAppsTy tys)
-  = hsep (map (ppr_app_ty . unLoc) tys)
+ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')
 
-ppr_mono_ty (HsAppTy fun_ty arg_ty)
+ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
   = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
 
-ppr_mono_ty (HsOpTy ty1 (L _ op) ty2)
+ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
   = sep [ ppr_mono_lty ty1
         , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
 
-ppr_mono_ty (HsParTy ty)
+ppr_mono_ty (HsParTy _ ty)
   = parens (ppr_mono_lty ty)
   -- Put the parens in where the user did
   -- But we still use the precedence stuff to add parens because
   --    toHsType doesn't put in any HsParTys, so we may still need them
 
-ppr_mono_ty (HsDocTy ty doc)
+ppr_mono_ty (HsDocTy _ ty doc)
   -- AZ: Should we add parens?  Should we introduce "-- ^"?
   = ppr_mono_lty ty <+> ppr (unLoc doc)
   -- we pretty print Haddock comments on types as if they were
   -- postfix operators
 
+ppr_mono_ty (XHsType t) = ppr t
+
 --------------------------
-ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
-           => LHsType pass -> LHsType pass -> SDoc
+ppr_fun_ty :: (OutputableBndrId (GhcPass p))
+           => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
 ppr_fun_ty ty1 ty2
   = let p1 = ppr_mono_lty ty1
         p2 = ppr_mono_lty ty2
@@ -1346,18 +1455,43 @@ ppr_fun_ty ty1 ty2
     sep [p1, text "->" <+> p2]
 
 --------------------------
-ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
-           => HsAppType pass -> SDoc
-ppr_app_ty (HsAppInfix (L _ n))                  = pprInfixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
-  = pprPrefixOcc n
-ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted  (L _ n))))
-  = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
-                                    -- the parser does not attach it to the
-                                    -- previous symbol
-ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
-
---------------------------
 ppr_tylit :: HsTyLit -> SDoc
 ppr_tylit (HsNumTy _ i) = integer i
 ppr_tylit (HsStrTy _ s) = text (show s)
+
+
+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
+-- under precedence @p@.
+hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
+hsTypeNeedsParens p = go
+  where
+    go (HsForAllTy{})        = p >= funPrec
+    go (HsQualTy{})          = p >= funPrec
+    go (HsBangTy{})          = p > topPrec
+    go (HsRecTy{})           = False
+    go (HsTyVar{})           = False
+    go (HsFunTy{})           = p >= funPrec
+    go (HsTupleTy{})         = False
+    go (HsSumTy{})           = False
+    go (HsKindSig{})         = False
+    go (HsListTy{})          = False
+    go (HsIParamTy{})        = p > topPrec
+    go (HsSpliceTy{})        = False
+    go (HsExplicitListTy{})  = False
+    go (HsExplicitTupleTy{}) = False
+    go (HsTyLit{})           = False
+    go (HsWildCardTy{})      = False
+    go (HsStarTy{})          = False
+    go (HsAppTy{})           = p >= appPrec
+    go (HsOpTy{})            = p >= opPrec
+    go (HsParTy{})           = False
+    go (HsDocTy _ (L _ t) _) = go t
+    go (XHsType{})           = False
+
+-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
+-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
+-- returns @ty@.
+parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+parenthesizeHsType p lty@(L loc ty)
+  | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty)
+  | otherwise              = lty
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ba001ea7ff..c3537266e3 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -20,7 +20,7 @@ which deal with the instantiated versions are located elsewhere:
 
 module HsUtils(
   -- Terms
-  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsCaseAlt,
+  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -50,7 +50,7 @@ module HsUtils(
   -- Patterns
   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
-  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
+  nlWildPatName, nlTuplePat, mkParPat, nlParPat,
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
   -- Types
@@ -63,16 +63,14 @@ module HsUtils(
   mkLastStmt,
   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
+  unitRecStmtTc,
 
   -- Template Haskell
   mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
   mkHsQuasiQuote, unqualQuasiQuote,
 
-  -- Flags
-  noRebindableInfo,
-
   -- Collecting binders
-  isUnliftedHsBind, isBangedBind,
+  isUnliftedHsBind, isBangedHsBind,
 
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   collectHsIdBinders,
@@ -84,7 +82,6 @@ module HsUtils(
   hsLTyClDeclBinders, hsTyClForeignBinders,
   hsPatSynSelectors, getPatSynBinds,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-  hsDataDefnBinders,
 
   -- Collecting implicit binders
   lStmtsImplicits, hsValBindsImplicits, lPatImplicits
@@ -92,6 +89,8 @@ module HsUtils(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsDecls
 import HsBinds
 import HsExpr
@@ -121,6 +120,7 @@ import Util
 import Bag
 import Outputable
 import Constants
+import TyCon
 
 import Data.Either
 import Data.Function
@@ -138,53 +138,60 @@ from their components, compared with the nl* functions below which
 just attach noSrcSpan to everything.
 -}
 
-mkHsPar :: LHsExpr id -> LHsExpr id
-mkHsPar e = L (getLoc e) (HsPar e)
+mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsPar e = L (getLoc e) (HsPar noExt e)
 
-mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
-              -> [LPat id] -> Located (body id)
-              -> LMatch id (Located (body id))
+mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
+              -> LMatch (GhcPass p) (Located (body (GhcPass p)))
 mkSimpleMatch ctxt pats rhs
   = L loc $
-    Match ctxt pats Nothing (unguardedGRHSs rhs)
+    Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
+          , m_grhss = unguardedGRHSs rhs }
   where
     loc = case pats of
                 []      -> getLoc rhs
                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 
-unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
+unguardedGRHSs :: Located (body (GhcPass p))
+               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
 unguardedGRHSs rhs@(L loc _)
-  = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
+  = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
 
-unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
-unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
+unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
+             -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
+unguardedRHS loc rhs = [L loc (GRHS noExt [] rhs)]
 
-mkMatchGroup :: (PostTc name Type ~ PlaceHolder)
+mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
              => Origin -> [LMatch name (Located (body name))]
              -> MatchGroup name (Located (body name))
-mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
-                                 , mg_arg_tys = []
-                                 , mg_res_ty = placeHolderType
+mkMatchGroup origin matches = MG { mg_ext = noExt
+                                 , mg_alts = mkLocatedList matches
                                  , mg_origin = origin }
 
 mkLocatedList ::  [Located a] -> Located [Located a]
 mkLocatedList [] = noLoc []
 mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
 
-mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
-mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
+mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
 
-mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
-mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
+mkHsAppType :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+            => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
+mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
+  where
+    t_body    = hswc_body t
+    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
 
-mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc
-mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
+mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
+mkHsAppTypes = foldl' mkHsAppType
 
 mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
   where
     matches = mkMatchGroup Generated
-                           [mkSimpleMatch LambdaExpr pats body]
+                           [mkSimpleMatch LambdaExpr pats' body]
+    pats' = map (parenthesizePat appPrec) pats
 
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
@@ -192,39 +199,40 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
 
 -- |A simple case alternative with a single pattern, no binds, no guards;
 -- pre-typechecking
-mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
+mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
+            -> LMatch (GhcPass p) (Located (body (GhcPass p)))
 mkHsCaseAlt pat expr
   = mkSimpleMatch CaseAlt [pat] expr
 
-nlHsTyApp :: IdP name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
+nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
+nlHsTyApp fun_id tys
+  = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))
 
-nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name
-nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
+nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
+           -> LHsExpr (GhcPass id)
+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
+mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
 -- So   'f x'  becomes '(f x)', but '3' stays as '3'
-mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
-                      | otherwise           = le
+mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExt le)
+                      | otherwise                   = le
 
-mkParPat :: LPat name -> LPat name
-mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
-                      | otherwise          = lp
+mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExt lp)
+                      | otherwise                = lp
 
-nlParPat :: LPat name -> LPat name
-nlParPat p = noLoc (ParPat p)
+nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+nlParPat p = noLoc (ParPat noExt p)
 
 -------------------------------
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 
-mkHsIntegral   :: IntegralLit -> PostTc GhcPs Type
-               -> HsOverLit GhcPs
-mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs
-mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type
-             -> HsOverLit GhcPs
+mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
+mkHsFractional :: FractionalLit -> HsOverLit GhcPs
+mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
 mkHsDo         :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
 mkHsComp       :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> HsExpr GhcPs
@@ -233,135 +241,144 @@ mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
             -> Pat GhcPs
 mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
 
-mkLastStmt :: SourceTextX idR
-           => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkLastStmt :: Located (bodyR (GhcPass idR))
+           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 mkBodyStmt :: Located (bodyR GhcPs)
-           -> StmtLR idL GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-           => LPat idL -> Located (bodyR idR)
-           -> StmtLR idL idR (Located (bodyR idR))
+           -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
+mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
+                         (Located (bodyR (GhcPass idR))) ~ NoExt)
+           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
+           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
              -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
 
-emptyRecStmt     :: StmtLR idL  GhcPs bodyR
+emptyRecStmt     :: StmtLR (GhcPass idL) GhcPs bodyR
 emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
 emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR
-mkRecStmt    :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
+mkRecStmt        :: [LStmtLR (GhcPass idL) GhcPs bodyR]
+                 -> StmtLR (GhcPass idL) GhcPs bodyR
 
 
-mkHsIntegral     i  = OverLit (HsIntegral       i) noRebindableInfo noExpr
-mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
-mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
+mkHsIntegral     i  = OverLit noExt (HsIntegral       i) noExpr
+mkHsFractional   f  = OverLit noExt (HsFractional     f) noExpr
+mkHsIsString src s  = OverLit noExt (HsIsString   src s) noExpr
 
-noRebindableInfo :: PlaceHolder
-noRebindableInfo = PlaceHolder -- Just another placeholder;
-
-mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType
+mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
 mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
   where
     last_stmt = L (getLoc expr) $ mkLastStmt expr
 
-mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
-mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
-
-mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
-mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
-
-mkTransformStmt    :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-                   => [ExprLStmt idL] -> LHsExpr idR
-                   -> StmtLR idL idR (LHsExpr idL)
-mkTransformByStmt  :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
-                   -> StmtLR idL idR (LHsExpr idL)
-mkGroupUsingStmt   :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-                   => [ExprLStmt idL]                -> LHsExpr idR
-                   -> StmtLR idL idR (LHsExpr idL)
-mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
-                   -> StmtLR idL idR (LHsExpr idL)
-
-emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
-               => StmtLR idL idR (LHsExpr idR)
-emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
+mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+       -> HsExpr (GhcPass p)
+mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
+
+mkNPat lit neg     = NPat noExt lit neg noSyntaxExpr
+mkNPlusKPat id lit
+  = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
+
+mkTransformStmt    :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkTransformByStmt  :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkGroupUsingStmt   :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
+                   -> LHsExpr GhcPs
+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+
+emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+emptyTransStmt = TransStmt { trS_ext = noExt
+                           , trS_form = panic "emptyTransStmt: form"
                            , trS_stmts = [], trS_bndrs = []
                            , trS_by = Nothing, trS_using = noLoc noExpr
                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
-                           , trS_bind_arg_ty = PlaceHolder
                            , trS_fmap = noExpr }
 mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
 mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
 mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
 mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
 
-mkLastStmt body     = LastStmt body False noSyntaxExpr
-mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
-mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
-mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
+mkLastStmt body = LastStmt noExt body False noSyntaxExpr
+mkBodyStmt body
+  = BodyStmt noExt body noSyntaxExpr noSyntaxExpr
+mkBindStmt pat body
+  = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr
+mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
   -- don't use placeHolderTypeTc above, because that panics during zonking
 
-emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
-                       PostTc idR Type -> StmtLR idL idR body
+emptyRecStmt' :: forall idL idR body.
+                 XRecStmt (GhcPass idL) (GhcPass idR) body
+              -> StmtLR (GhcPass idL) (GhcPass idR) body
 emptyRecStmt' tyVal =
    RecStmt
      { recS_stmts = [], recS_later_ids = []
      , recS_rec_ids = []
      , recS_ret_fn = noSyntaxExpr
      , recS_mfix_fn = noSyntaxExpr
-     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
-     , recS_later_rets = []
-     , recS_rec_rets = [], recS_ret_ty = tyVal }
-
-emptyRecStmt     = emptyRecStmt' placeHolderType
-emptyRecStmtName = emptyRecStmt' placeHolderType
-emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
+     , recS_bind_fn = noSyntaxExpr
+     , recS_ext = tyVal }
+
+unitRecStmtTc :: RecStmtTc
+unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
+                          , recS_later_rets = []
+                          , recS_rec_rets = []
+                          , recS_ret_ty = unitTy }
+
+emptyRecStmt     = emptyRecStmt' noExt
+emptyRecStmtName = emptyRecStmt' noExt
+emptyRecStmtId   = emptyRecStmt' unitRecStmtTc
+                                        -- a panic might trigger during zonking
 mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
 
 -------------------------------
 --- A useful function for building @OpApps@.  The operator is always a
 -- variable, and we don't know the fixity yet.
-mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id
-mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
-                           (error "mkOpApp:fixity") e2
+mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
+mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2
 
 unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 
 mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
-mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
+mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
 
 mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
+mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e)
 
 mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
+mkHsSpliceTE hasParen e
+  = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e)
 
 mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
-mkHsSpliceTy hasParen e
-  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
+mkHsSpliceTy hasParen e = HsSpliceTy noExt
+                      (HsUntypedSplice noExt hasParen unqualSplice e)
 
 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
-mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
+mkHsQuasiQuote quoter span quote
+  = HsQuasiQuote noExt unqualSplice quoter span quote
 
 unqualQuasiQuote :: RdrName
 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
                 -- A name (uniquified later) to
                 -- identify the quasi-quote
 
-mkHsString :: SourceTextX p => String -> HsLit p
-mkHsString s = HsString noSourceText (mkFastString s)
+mkHsString :: String -> HsLit (GhcPass p)
+mkHsString s = HsString NoSourceText (mkFastString s)
 
-mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
+mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
 mkHsStringPrimLit fs
-  = HsStringPrim noSourceText (fastStringToByteString fs)
+  = HsStringPrim NoSourceText (fastStringToByteString fs)
 
 -------------
-userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
+userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
+                  -> [LHsTyVarBndr (GhcPass p)]
 -- Caller sets location
-userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
+userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ]
 
-userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name]
+userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
 -- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
+userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v))
+                             | v <- bndrs ]
 
 
 {-
@@ -372,47 +389,49 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
 ************************************************************************
 -}
 
-nlHsVar :: IdP id -> LHsExpr id
-nlHsVar n = noLoc (HsVar (noLoc n))
+nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsVar n = noLoc (HsVar noExt (noLoc n))
 
 -- NB: Only for LHsExpr **Id**
 nlHsDataCon :: DataCon -> LHsExpr GhcTc
-nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con))
+nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
 
-nlHsLit :: HsLit p -> LHsExpr p
-nlHsLit n = noLoc (HsLit n)
+nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
+nlHsLit n = noLoc (HsLit noExt n)
 
-nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p
-nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n)))
+nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
+nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
 
-nlVarPat :: IdP id -> LPat id
-nlVarPat n = noLoc (VarPat (noLoc n))
+nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
+nlVarPat n = noLoc (VarPat noExt (noLoc n))
 
-nlLitPat :: HsLit p -> LPat p
-nlLitPat l = noLoc (LitPat l)
+nlLitPat :: HsLit GhcPs -> LPat GhcPs
+nlLitPat l = noLoc (LitPat noExt l)
 
-nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
-nlHsApp f x = noLoc (HsApp f (mkLHsPar x))
+nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
 
-nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
+nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
+               -> LHsExpr (GhcPass id)
 nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
                            , syn_arg_wraps = arg_wraps
                            , syn_res_wrap  = res_wrap }) args
   | [] <- arg_wraps   -- in the noSyntaxExpr case
   = ASSERT( isIdHsWrapper res_wrap )
-    foldl nlHsApp (noLoc fun) args
+    foldl' nlHsApp (noLoc fun) args
 
   | otherwise
-  = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
+  = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
                                                      mkLHsWrap arg_wraps args))
 
-nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id
-nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
+nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
 
-nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id
-nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
+nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
+                                               (map ((HsVar noExt) . noLoc) xs))
                  where
-                   mk f a = HsApp (noLoc f) (noLoc a)
+                   mk f a = HsApp noExt (noLoc f) (noLoc a)
 
 nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
 nlConVarPat con vars = nlConPat con (map nlVarPat vars)
@@ -420,14 +439,18 @@ nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
 
-nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
+nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
+nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
+                              (InfixCon (parenthesizePat opPrec l)
+                                        (parenthesizePat opPrec r)))
 
 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
-nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+nlConPat con pats =
+  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
 
 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
-nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
+nlConPatName con pats =
+  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
 
 nlNullaryConPat :: IdP id -> LPat id
 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
@@ -438,88 +461,94 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                              nlWildPat)))
 
 nlWildPat :: LPat GhcPs
-nlWildPat  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
+nlWildPat  = noLoc (WildPat noExt )  -- Pre-typechecking
 
 nlWildPatName :: LPat GhcRn
-nlWildPatName  = noLoc (WildPat placeHolderType )  -- Pre-typechecking
-
-nlWildPatId :: LPat GhcTc
-nlWildPatId  = noLoc (WildPat placeHolderTypeTc )  -- Post-typechecking
+nlWildPatName  = noLoc (WildPat noExt )  -- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
        -> LHsExpr GhcPs
 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
 
-nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id
+nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
 nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
 
 nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
-nlHsPar  :: LHsExpr id -> LHsExpr id
-nlHsIf   :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsIf   :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+         -> LHsExpr (GhcPass id)
 nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
          -> LHsExpr GhcPs
 nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
 
-nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
-nlHsPar e              = noLoc (HsPar e)
+nlHsLam match          = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
+nlHsPar e              = noLoc (HsPar noExt e)
 
 -- Note [Rebindable nlHsIf]
 -- nlHsIf should generate if-expressions which are NOT subject to
 -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
-nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
+nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
 
-nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
-nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
+nlHsCase expr matches
+  = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
+nlList exprs          = noLoc (ExplicitList noExt Nothing exprs)
 
-nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
-nlHsTyVar :: IdP name                     -> LHsType name
-nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
-nlHsParTy :: LHsType name                 -> LHsType name
+nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)
+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
 
-nlHsAppTy f t           = noLoc (HsAppTy f t)
-nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
-nlHsFunTy a b           = noLoc (HsFunTy a b)
-nlHsParTy t             = noLoc (HsParTy t)
+nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
+nlHsTyVar x   = noLoc (HsTyVar noExt NotPromoted (noLoc x))
+nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a)
+                                     (parenthesize_fun_tail b))
+  where
+    parenthesize_fun_tail (L loc (HsFunTy ext ty1 ty2))
+      = L loc (HsFunTy ext (parenthesizeHsType funPrec ty1)
+                           (parenthesize_fun_tail ty2))
+    parenthesize_fun_tail lty = lty
+nlHsParTy t   = noLoc (HsParTy noExt t)
 
-nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name
-nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
+nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
+nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys
 
 {-
 Tuples.  All these functions are *pre-typechecker* because they lack
 types on the tuple.
 -}
 
-mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
+mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
 -- Makes a pre-typechecker boxed tuple, deals with 1 case
 mkLHsTupleExpr [e] = e
-mkLHsTupleExpr es  = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed
+mkLHsTupleExpr es
+  = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
 
-mkLHsVarTuple :: [IdP a] -> LHsExpr a
+mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
 mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)
 
-nlTuplePat :: [LPat id] -> Boxity -> LPat id
-nlTuplePat pats box = noLoc (TuplePat pats box [])
+nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
+nlTuplePat pats box = noLoc (TuplePat noExt pats box)
 
 missingTupArg :: HsTupArg GhcPs
-missingTupArg = Missing placeHolderType
+missingTupArg = Missing noExt
 
-mkLHsPatTup :: [LPat id] -> LPat id
-mkLHsPatTup []     = noLoc $ TuplePat [] Boxed []
+mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
+mkLHsPatTup []     = noLoc $ TuplePat noExt [] Boxed
 mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
+mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
 
 -- The Big equivalents for the source tuple expressions
-mkBigLHsVarTup :: [IdP id] -> LHsExpr id
+mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
 
-mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
+mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
 mkBigLHsTup = mkChunkified mkLHsTupleExpr
 
 -- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTup :: [IdP id] -> LPat id
+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
 
-mkBigLHsPatTup :: [LPat id] -> LPat id
+mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
 mkBigLHsPatTup = mkChunkified mkLHsPatTup
 
 -- $big_tuples
@@ -595,8 +624,8 @@ mkHsSigEnv get_info sigs
    -- of which use this function
   where
     (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
-    is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
-    is_gen_dm_sig _                           = False
+    is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
+    is_gen_dm_sig _                             = False
 
     mk_pairs :: [LSig GhcRn] -> [(Name, a)]
     mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
@@ -609,8 +638,9 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
 mkClassOpSigs sigs
   = map fiddle sigs
   where
-    fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
-    fiddle sig                      = sig
+    fiddle (L loc (TypeSig _ nms ty))
+      = L loc (ClassOpSig noExt False nms (dropWildCards ty))
+    fiddle sig = sig
 
 typeToLHsType :: Type -> LHsType GhcPs
 -- ^ Converting a Type to an HsType RdrName
@@ -626,19 +656,29 @@ typeToLHsType ty
       | isPredTy arg
       , (theta, tau) <- tcSplitPhiTy ty
       = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
+                        , hst_xqual = noExt
                         , hst_body = go tau })
     go (FunTy arg res) = nlHsFunTy (go arg) (go res)
     go ty@(ForAllTy {})
       | (tvs, tau) <- tcSplitForAllTys ty
       = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
+                          , hst_xforall = noExt
                           , hst_body = go tau })
     go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
     go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
-    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
-    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
-    go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
+    go (LitTy (NumTyLit n))
+      = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
+    go (LitTy (StrTyLit s))
+      = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)
+    go ty@(TyConApp tc args)
+      | any isInvisibleTyConBinder (tyConBinders tc)
+        -- We must produce an explicit kind signature here to make certain
+        -- programs kind-check. See Note [Kind signatures in typeToLHsType].
+      = noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))
+      | otherwise = lhs_ty
        where
-         args' = filterOutInvisibleTypes tc args
+        lhs_ty = nlHsTyConApp (getRdrName tc) (map go args')
+        args'  = filterOutInvisibleTypes tc args
     go (CastTy ty _)        = go ty
     go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)
 
@@ -646,9 +686,58 @@ typeToLHsType ty
          -- so we must remove them here (Trac #8563)
 
     go_tv :: TyVar -> LHsTyVarBndr GhcPs
-    go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
+    go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
                                    (go (tyVarKind tv))
 
+{-
+Note [Kind signatures in typeToLHsType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are types that typeToLHsType can produce which require explicit kind
+signatures in order to kind-check. Here is an example from Trac #14579:
+
+  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) deriving Eq
+  newtype Glurp a = MkGlurp (Wat ('Proxy :: Proxy a)) deriving Eq
+
+The derived Eq instance for Glurp (without any kind signatures) would be:
+
+  instance Eq a => Eq (Glurp a) where
+    (==) = coerce @(Wat 'Proxy -> Wat 'Proxy -> Bool)
+                  @(Glurp a    -> Glurp a    -> Bool)
+                  (==) :: Glurp a -> Glurp a -> Bool
+
+(Where the visible type applications use types produced by typeToLHsType.)
+
+The type 'Proxy has an underspecified kind, so we must ensure that
+typeToLHsType ascribes it with its kind: ('Proxy :: Proxy a).
+
+We must be careful not to produce too many kind signatures, or else
+typeToLHsType can produce noisy types like
+('Proxy :: Proxy (a :: (Type :: Type))). In pursuit of this goal, we adopt the
+following criterion for choosing when to annotate types with kinds:
+
+* If there is a tycon application with any invisible arguments, annotate
+  the tycon application with its kind.
+
+Why is this the right criterion? The problem we encountered earlier was the
+result of an invisible argument (the `a` in ('Proxy :: Proxy a)) being
+underspecified, so producing a kind signature for 'Proxy will catch this.
+If there are no invisible arguments, then there is nothing to do, so we can
+avoid polluting the result type with redundant noise.
+
+What about a more complicated tycon, such as this?
+
+  T :: forall {j} (a :: j). a -> Type
+
+Unlike in the previous 'Proxy example, annotating an application of `T` to an
+argument (e.g., annotating T ty to obtain (T ty :: Type)) will not fix
+its invisible argument `j`. But because we apply this strategy recursively,
+`j` will be fixed because the kind of `ty` will be fixed! That is to say,
+something to the effect of (T (ty :: j) :: Type) will be produced.
+
+This strategy certainly isn't foolproof, as tycons that contain type families
+in their kind might break down. But we'd likely need visible kind application
+to make those work.
+-}
 
 {- *********************************************************************
 *                                                                      *
@@ -656,41 +745,41 @@ typeToLHsType ty
 *                                                                      *
 ********************************************************************* -}
 
-mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 -- Avoid (HsWrap co (HsWrap co' _)).
 -- See Note [Detecting forced eta expansion] in DsExpr
-mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-mkHsWrap co_fn (HsWrap co_fn' e)       = mkHsWrap (co_fn <.> co_fn') e
-mkHsWrap co_fn e                       = HsWrap co_fn e
+mkHsWrap co_fn (HsWrap _ co_fn' e)     = mkHsWrap (co_fn <.> co_fn') e
+mkHsWrap co_fn e                       = HsWrap noExt co_fn e
 
 mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
-           -> HsExpr id -> HsExpr id
+           -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
 mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
 
 mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
-            -> HsExpr id -> HsExpr id
+            -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
 mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
 
-mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
 
-mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
+mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
 mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
-                  | otherwise       = HsCmdWrap w cmd
+                  | otherwise       = HsCmdWrap noExt w cmd
 
-mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
+mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
 mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
 
-mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
-                       | otherwise           = CoPat co_fn p ty
+                       | otherwise           = CoPat noExt co_fn p ty
 
-mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
-                        | otherwise     = CoPat (mkWpCastN co) pat ty
+                        | otherwise    = CoPat noExt (mkWpCastN co) pat ty
 
 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -710,7 +799,7 @@ mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
 mkFunBind fn ms = FunBind { fun_id = fn
                           , fun_matches = mkMatchGroup Generated ms
                           , fun_co_fn = idHsWrapper
-                          , bind_fvs = placeHolderNames
+                          , fun_ext = noExt
                           , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
@@ -719,31 +808,32 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
 mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_matches = mkMatchGroup origin ms
                                     , fun_co_fn = idHsWrapper
-                                    , bind_fvs = emptyNameSet -- NB: closed
+                                    , fun_ext  = emptyNameSet -- NB: closed
                                                               --     binding
                                     , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
-mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
+mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
 mkVarBind var rhs = L (getLoc rhs) $
-                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
+                    VarBind { var_ext = noExt,
+                              var_id = var, var_rhs = rhs, var_inline = False }
 
 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
              -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
-mkPatSynBind name details lpat dir = PatSynBind psb
+mkPatSynBind name details lpat dir = PatSynBind noExt psb
   where
-    psb = PSB{ psb_id = name
+    psb = PSB{ psb_ext = noExt
+             , psb_id = name
              , psb_args = details
              , psb_def = lpat
-             , psb_dir = dir
-             , psb_fvs = placeHolderNames }
+             , psb_dir = dir }
 
 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
 -- considered infix.
 isInfixFunBind :: HsBindLR id1 id2 -> Bool
-isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
+isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
   = any (isInfixMatch . unLoc) (unLoc matches)
 isInfixFunBind _ = False
 
@@ -758,17 +848,23 @@ mk_easy_FunBind loc fun pats expr
 
 -- | Make a prefix, non-strict function 'HsMatchContext'
 mkPrefixFunRhs :: Located id -> HsMatchContext id
-mkPrefixFunRhs n = FunRhs n Prefix NoSrcStrict
+mkPrefixFunRhs n = FunRhs { mc_fun = n
+                          , mc_fixity = Prefix
+                          , mc_strictness = NoSrcStrict }
 
 ------------
-mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p
-        -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p)
+mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+        -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+        -> Located (HsLocalBinds (GhcPass p))
+        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
 mkMatch ctxt pats expr lbinds
-  = noLoc (Match ctxt (map paren pats) Nothing
-                 (GRHSs (unguardedRHS noSrcSpan expr) lbinds))
+  = noLoc (Match { m_ext   = noExt
+                 , m_ctxt  = ctxt
+                 , m_pats  = map paren pats
+                 , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
   where
-    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
-                     | otherwise          = lp
+    paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExt lp)
+                     | otherwise                = lp
 
 {-
 ************************************************************************
@@ -794,49 +890,31 @@ to return a [Name] or [Id].  Before renaming the record punning
 and wild-card mechanism makes it hard to know what is bound.
 So these functions should not be applied to (HsSyn RdrName)
 
-Note [Unlifted id check in isHsUnliftedBind]
+Note [Unlifted id check in isUnliftedHsBind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
-strict binding that should be disallowed at the top level? At first glance,
-no, because it's a function. But consider how this is desugared via
-AbsBinds:
-
-  -- x :: Num a => (# a, a #)
-  x = (# 3, 4 #)
-
-becomes
-
-  x = \ $dictNum ->
-      let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
-      x_mono
-
-Note that the inner let is strict. And thus if we have a bunch of mutually
-recursive bindings of this form, we could end up in trouble. This was shown
-up in #9140.
+The function isUnliftedHsBind is used to complain if we make a top-level
+binding for a variable of unlifted type.
 
-But if there is a type signature on x, everything changes because of the
-desugaring used by AbsBindsSig:
+Such a binding is illegal if the top-level binding would be unlifted;
+but also if the local letrec generated by desugaring AbsBinds would be.
+E.g.
+      f :: Num a => (# a, a #)
+      g :: Num a => a -> a
+      f = ...g...
+      g = ...g...
 
-  x :: Num a => (# a, a #)
-  x = (# 3, 4 #)
+The top-level bindings for f,g are not unlifted (because of the Num a =>),
+but the local, recursive, monomorphic bindings are:
 
-becomes
+      t = /\a \(d:Num a).
+         letrec fm :: (# a, a #) = ...g...
+                gm :: a -> a = ...f...
+         in (fm, gm)
 
-  x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
-
-No strictness anymore! The bottom line here is that, for inferred types, we
-care about the strictness of the type after the =>. For checked types
-(AbsBindsSig), we care about the overall strictness.
-
-This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
-a problem when compiling
-
-  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
-
-Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
-if you try.) Looking at the whole type, on the other hand, tells you that this
-is a lifted function type, with no trouble at all.
+Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.
 
+BUT we have a special case when abs_sig is true;
+  see HsBinds Note [The abs_sig field of AbsBinds]
 -}
 
 ----------------- Bindings --------------------------
@@ -846,35 +924,43 @@ is a lifted function type, with no trouble at all.
 -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
 -- information, see Note [Strict binds check] is DsBinds.
 isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds
-isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
-  = isUnliftedType (idType id)
 isUnliftedHsBind bind
+  | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
+  = if has_sig
+    then any (is_unlifted_id . abe_poly) exports
+    else any (is_unlifted_id . abe_mono) exports
+    -- If has_sig is True we wil never generate a binding for abe_mono,
+    -- so we don't need to worry about it being unlifted. The abe_poly
+    -- binding might not be: e.g. forall a. Num a => (# a, a #)
+
+  | otherwise
   = any is_unlifted_id (collectHsBindBinders bind)
   where
-    is_unlifted_id id
-      = case tcSplitSigmaTy (idType id) of
-          (_, _, tau) -> isUnliftedType tau
-          -- For the is_unlifted check, we need to look inside polymorphism
-          -- and overloading.  E.g.  x = (# 1, True #)
-          -- would get type forall a. Num a => (# a, Bool #)
-          -- and we want to reject that.  See Trac #9140
-
--- | Is a binding a strict variable bind (e.g. @!x = ...@)?
-isBangedBind :: HsBind GhcTc -> Bool
-isBangedBind b | isBangedPatBind b = True
-isBangedBind (FunBind {fun_matches = matches})
+    is_unlifted_id id = isUnliftedType (idType id)
+
+-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
+isBangedHsBind :: HsBind GhcTc -> Bool
+isBangedHsBind (AbsBinds { abs_binds = binds })
+  = anyBag (isBangedHsBind . unLoc) binds
+isBangedHsBind (FunBind {fun_matches = matches})
   | [L _ match] <- unLoc $ mg_alts matches
   , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
   = True
-isBangedBind _ = False
-
-collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL]
-collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
+isBangedHsBind (PatBind {pat_lhs = pat})
+  = isBangedLPat pat
+isBangedHsBind _
+  = False
+
+collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+                    -> [IdP (GhcPass idL)]
+collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
                                          -- No pattern synonyms here
-collectLocalBinders (HsIPBinds _)      = []
-collectLocalBinders EmptyLocalBinds    = []
+collectLocalBinders (HsIPBinds {})      = []
+collectLocalBinders (EmptyLocalBinds _) = []
+collectLocalBinders (XHsLocalBindsLR _) = []
 
-collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL]
+collectHsIdBinders, collectHsValBinders
+  :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
 -- Collect Id binders only, or Ids + pattern synonyms, respectively
 collectHsIdBinders  = collect_hs_val_binders True
 collectHsValBinders = collect_hs_val_binders False
@@ -890,9 +976,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL]
 -- Same as collectHsBindsBinders, but works over a list of bindings
 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
 
-collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL]
-collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []
-collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+                       -> [IdP (GhcPass idL)]
+collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
+collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
+  = collect_out_binds ps binds
 
 collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p]
 collect_out_binds ps = foldr (collect_binds ps . snd) []
@@ -907,14 +995,15 @@ collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
 collect_bind _ (VarBind { var_id = f })            acc = f : acc
 collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
         -- I don't think we want the binders from the abe_binds
-        -- The only time we collect binders from a typechecked
+
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
-collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
+collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
   | omitPatSyn                  = acc
   | otherwise                   = ps : acc
+collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
+collect_bind _ (XHsBindsLR _) acc = acc
 
-collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
+collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
 collectMethodBinders binds = foldrBag (get . unLoc) [] binds
   where
@@ -923,26 +1012,35 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds
        -- Someone else complains about non-FunBinds
 
 ----------------- Statements --------------------------
-collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL]
+collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
+                     -> [IdP (GhcPass idL)]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL]
+collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
+                    -> [IdP (GhcPass idL)]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL]
+collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
+                    -> [IdP (GhcPass idL)]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: StmtLR idL idR body -> [IdP idL]
+collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
+                   -> [IdP (GhcPass idL)]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
-collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
-collectStmtBinders (BodyStmt {})         = []
-collectStmtBinders (LastStmt {})         = []
-collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
-                                      $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+collectStmtBinders (BindStmt _ pat _ _ _)  = collectPatBinders pat
+collectStmtBinders (LetStmt _ (L _ binds)) = collectLocalBinders binds
+collectStmtBinders (BodyStmt {})           = []
+collectStmtBinders (LastStmt {})           = []
+collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders
+                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
-collectStmtBinders ApplicativeStmt{} = []
+collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
+ where
+  collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
+  collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+  collectArgBinders _ = []
+collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
 
 
 ----------------- Patterns --------------------------
@@ -957,33 +1055,32 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass]
 collect_lpat (L _ pat) bndrs
   = go pat
   where
-    go (VarPat (L _ var))         = var : bndrs
+    go (VarPat _ (L _ var))       = var : bndrs
     go (WildPat _)                = bndrs
-    go (LazyPat pat)              = collect_lpat pat bndrs
-    go (BangPat pat)              = collect_lpat pat bndrs
-    go (AsPat (L _ a) pat)        = a : collect_lpat pat bndrs
-    go (ViewPat _ pat _)          = collect_lpat pat bndrs
-    go (ParPat  pat)              = collect_lpat pat bndrs
+    go (LazyPat _ pat)            = collect_lpat pat bndrs
+    go (BangPat _ pat)            = collect_lpat pat bndrs
+    go (AsPat _ (L _ a) pat)      = a : collect_lpat pat bndrs
+    go (ViewPat _ _ pat)          = collect_lpat pat bndrs
+    go (ParPat _ pat)             = collect_lpat pat bndrs
 
-    go (ListPat pats _ _)         = foldr collect_lpat bndrs pats
-    go (PArrPat pats _)           = foldr collect_lpat bndrs pats
-    go (TuplePat pats _ _)        = foldr collect_lpat bndrs pats
-    go (SumPat pat _ _ _)         = collect_lpat pat bndrs
+    go (ListPat _ pats)           = foldr collect_lpat bndrs pats
+    go (TuplePat _ pats _)        = foldr collect_lpat bndrs pats
+    go (SumPat _ pat _ _)         = collect_lpat pat bndrs
 
     go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
         -- See Note [Dictionary binders in ConPatOut]
-    go (LitPat _)                 = bndrs
-    go (NPat {})                  = bndrs
-    go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
+    go (LitPat _ _)                 = bndrs
+    go (NPat {})                    = bndrs
+    go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs
 
-    go (SigPatIn pat _)           = collect_lpat pat bndrs
-    go (SigPatOut pat _)          = collect_lpat pat bndrs
+    go (SigPat _ pat)               = collect_lpat pat bndrs
 
-    go (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+    go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                   = go pat
-    go (SplicePat _)              = bndrs
-    go (CoPat _ pat _)            = go pat
+    go (SplicePat _ _)            = bndrs
+    go (CoPat _ _ pat _)          = go pat
+    go (XPat {})                  = bndrs
 
 {-
 Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
@@ -1018,6 +1115,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                           hs_fords = foreign_decls })
   =  collectHsValBinders val_decls
   ++ hsTyClForeignBinders tycl_decls foreign_decls
+hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders"
 
 hsTyClForeignBinders :: [TyClGroup GhcRn]
                      -> [LForeignDecl GhcRn]
@@ -1032,7 +1130,7 @@ hsTyClForeignBinders tycl_decls foreign_decls
          foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
   where
     getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
-    getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
+    getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
 
 -------------------
 hsLTyClDeclBinders :: Located (TyClDecl pass)
@@ -1048,15 +1146,19 @@ hsLTyClDeclBinders :: Located (TyClDecl pass)
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
   = ([L loc name], [])
+hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl _ }))
+  = panic "hsLTyClDeclBinders"
 hsLTyClDeclBinders (L loc (SynDecl     { tcdLName = L _ name })) = ([L loc name], [])
 hsLTyClDeclBinders (L loc (ClassDecl   { tcdLName = L _ cls_name
                                        , tcdSigs = sigs, tcdATs = ats }))
   = (L loc cls_name :
      [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
-     [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
+     [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs
+                          , L _ mem_name <- ns ]
     , [])
 hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn }))
   = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
+hsLTyClDeclBinders (L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
 
 -------------------
 hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
@@ -1067,40 +1169,50 @@ hsForeignDeclsBinders foreign_decls
 
 
 -------------------
-hsPatSynSelectors :: HsValBinds p -> [IdP p]
+hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
 -- Collects record pattern-synonym selectors only; the pattern synonym
 -- names are collected by collectHsValBinders.
-hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors"
-hsPatSynSelectors (ValBindsOut binds _)
+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
+hsPatSynSelectors (XValBindsLR (NValBinds binds _))
   = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
 
 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
 addPatSynSelector bind sels
-  | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
+  | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind
   = map (unLoc . recordPatSynSelectorId) as ++ sels
   | otherwise = sels
 
 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
 getPatSynBinds binds
   = [ psb | (_, lbinds) <- binds
-          , L _ (PatSynBind psb) <- bagToList lbinds ]
+          , L _ (PatSynBind _ psb) <- bagToList lbinds ]
 
 -------------------
-hsLInstDeclBinders :: LInstDecl pass
-                   -> ([Located (IdP pass)], [LFieldOcc pass])
+hsLInstDeclBinders :: LInstDecl (GhcPass p)
+                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
 hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
   = foldMap (hsDataFamInstBinders . unLoc) dfis
 hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
   = hsDataFamInstBinders fi
 hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
+hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {})))
+  = panic "hsLInstDeclBinders"
+hsLInstDeclBinders (L _ (XInstDecl _))
+  = panic "hsLInstDeclBinders"
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
 hsDataFamInstBinders :: DataFamInstDecl pass
                      -> ([Located (IdP pass)], [LFieldOcc pass])
-hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                       FamEqn { feqn_rhs = defn }}})
   = hsDataDefnBinders defn
   -- There can't be repeated symbols because only data instances have binders
+hsDataFamInstBinders (DataFamInstDecl
+                                    { dfid_eqn = HsIB { hsib_body = XFamEqn _}})
+  = panic "hsDataFamInstBinders"
+hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "hsDataFamInstBinders"
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
@@ -1108,57 +1220,53 @@ hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
 hsDataDefnBinders (HsDataDefn { dd_cons = cons })
   = hsConDeclsBinders cons
   -- See Note [Binders in family instances]
+hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"
 
 -------------------
+type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
+                 -- Filters out ones that have already been seen
+
 hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-  -- See hsLTyClDeclBinders for what this does
-  -- The function is boringly complicated because of the records
-  -- And since we only have equality, we have to be a little careful
-hsConDeclsBinders cons = go id cons
-  where go :: ([LFieldOcc pass] -> [LFieldOcc pass])
-           -> [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
-        go _ [] = ([], [])
-        go remSeen (r:rs) =
-          -- don't re-mangle the location of field names, because we don't
-          -- have a record of the full location of the field declaration anyway
-          case r of
-             -- remove only the first occurrence of any seen field in order to
-             -- avoid circumventing detection of duplicate fields (#9156)
-             L loc (ConDeclGADT { con_names = names
-                                , con_type = HsIB { hsib_body = res_ty}}) ->
-               case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                            [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-                         -> record_gadt flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-                         -> record_gadt flds
-
-                 _other  -> (map (L loc . unLoc) names ++ ns, fs)
-                            where (ns, fs) = go remSeen rs
-               where
-                 (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-                 record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
-                   where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
-                         remSeen' = foldr (.) remSeen
-                                        [deleteBy ((==) `on`
-                                              unLoc . rdrNameFieldOcc . unLoc) v
-                                        | v <- r']
-                         (ns, fs) = go remSeen' rs
-
-             L loc (ConDeclH98 { con_name = name
-                               , con_details = RecCon flds }) ->
-               ([L loc (unLoc name)] ++ ns, r' ++ fs)
-                  where r' = remSeen (concatMap (cd_fld_names . unLoc)
-                                                (unLoc flds))
-                        remSeen'
-                          = foldr (.) remSeen
-                               [deleteBy ((==) `on`
-                                   unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
-                        (ns, fs) = go remSeen' rs
-             L loc (ConDeclH98 { con_name = name }) ->
-                ([L loc (unLoc name)] ++ ns, fs)
-                  where (ns, fs) = go remSeen rs
+   -- See hsLTyClDeclBinders for what this does
+   -- The function is boringly complicated because of the records
+   -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons
+  = go id cons
+  where
+    go :: Seen pass -> [LConDecl pass]
+       -> ([Located (IdP pass)], [LFieldOcc pass])
+    go _ [] = ([], [])
+    go remSeen (r:rs)
+      -- Don't re-mangle the location of field names, because we don't
+      -- have a record of the full location of the field declaration anyway
+      = case r of
+           -- remove only the first occurrence of any seen field in order to
+           -- avoid circumventing detection of duplicate fields (#9156)
+           L loc (ConDeclGADT { con_names = names, con_args = args })
+             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+           L loc (ConDeclH98 { con_name = name, con_args = args })
+             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)
+             where
+                (remSeen', flds) = get_flds remSeen args
+                (ns, fs) = go remSeen' rs
+
+           L _ (XConDecl _) -> panic "hsConDeclsBinders"
+
+    get_flds :: Seen pass -> HsConDeclDetails pass
+             -> (Seen pass, [LFieldOcc pass])
+    get_flds remSeen (RecCon flds)
+       = (remSeen', fld_names)
+       where
+          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
+          remSeen' = foldr (.) remSeen
+                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
+                               | v <- fld_names]
+    get_flds remSeen _
+       = (remSeen, [])
 
 {-
 
@@ -1192,32 +1300,39 @@ The main purpose is to find names introduced by record wildcards so that we can
 warning the user when they don't use those names (#4404)
 -}
 
-lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+                -> NameSet
 lStmtsImplicits = hs_lstmts
   where
-    hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet
+    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
+              -> NameSet
     hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
 
-    hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet
-    hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
-    hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
-      where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
-            do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
-    hs_stmt (LetStmt binds)      = hs_local_binds (unLoc binds)
-    hs_stmt (BodyStmt {})        = emptyNameSet
-    hs_stmt (LastStmt {})        = emptyNameSet
-    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+    hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
+            -> NameSet
+    hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
+    hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args)
+      where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
+            do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
+            do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
+    hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)
+    hs_stmt (BodyStmt {})         = emptyNameSet
+    hs_stmt (LastStmt {})         = emptyNameSet
+    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
+                                                , s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
+    hs_stmt (XStmtLR {})          = panic "lStmtsImplicits"
 
-    hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
-    hs_local_binds (HsIPBinds _)         = emptyNameSet
-    hs_local_binds EmptyLocalBinds       = emptyNameSet
+    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
+    hs_local_binds (HsIPBinds {})           = emptyNameSet
+    hs_local_binds (EmptyLocalBinds _)      = emptyNameSet
+    hs_local_binds (XHsLocalBindsLR _)      = emptyNameSet
 
-hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet
-hsValBindsImplicits (ValBindsOut binds _)
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
+hsValBindsImplicits (XValBindsLR (NValBinds binds _))
   = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
-hsValBindsImplicits (ValBindsIn binds _)
+hsValBindsImplicits (ValBinds _ binds _)
   = lhsBindsImplicits binds
 
 lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
@@ -1233,18 +1348,16 @@ lPatImplicits = hs_lpat
 
     hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet
 
-    hs_pat (LazyPat pat)       = hs_lpat pat
-    hs_pat (BangPat pat)       = hs_lpat pat
-    hs_pat (AsPat _ pat)       = hs_lpat pat
-    hs_pat (ViewPat _ pat _)   = hs_lpat pat
-    hs_pat (ParPat  pat)       = hs_lpat pat
-    hs_pat (ListPat pats _ _)  = hs_lpats pats
-    hs_pat (PArrPat pats _)    = hs_lpats pats
-    hs_pat (TuplePat pats _ _) = hs_lpats pats
-
-    hs_pat (SigPatIn pat _)  = hs_lpat pat
-    hs_pat (SigPatOut pat _) = hs_lpat pat
-    hs_pat (CoPat _ pat _)   = hs_pat pat
+    hs_pat (LazyPat _ pat)      = hs_lpat pat
+    hs_pat (BangPat _ pat)      = hs_lpat pat
+    hs_pat (AsPat _ _ pat)      = hs_lpat pat
+    hs_pat (ViewPat _ _ pat)    = hs_lpat pat
+    hs_pat (ParPat _ pat)       = hs_lpat pat
+    hs_pat (ListPat _ pats)     = hs_lpats pats
+    hs_pat (TuplePat _ pats _)  = hs_lpats pats
+
+    hs_pat (SigPat _ pat)       = hs_lpat pat
+    hs_pat (CoPat _ _ pat _)    = hs_pat pat
 
     hs_pat (ConPatIn _ ps)           = details ps
     hs_pat (ConPatOut {pat_args=ps}) = details ps
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 5c716d259c..244243a82f 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -6,14 +6,11 @@
 
 module PlaceHolder where
 
-import Type       ( Type )
-import Outputable
 import Name
 import NameSet
 import RdrName
 import Var
 
-import Data.Data hiding ( Fixity )
 
 
 {-
@@ -27,32 +24,11 @@ import Data.Data hiding ( Fixity )
 -- NB: These are intentionally open, allowing API consumers (like Haddock)
 -- to declare new instances
 
--- | used as place holder in PostTc and PostRn values
-data PlaceHolder = PlaceHolder
-  deriving (Data)
-
-placeHolderKind :: PlaceHolder
-placeHolderKind = PlaceHolder
-
-placeHolderFixity :: PlaceHolder
-placeHolderFixity = PlaceHolder
-
-placeHolderType :: PlaceHolder
-placeHolderType = PlaceHolder
-
-placeHolderTypeTc :: Type
-placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType"
-
-placeHolderNames :: PlaceHolder
-placeHolderNames = PlaceHolder
-
 placeHolderNamesTc :: NameSet
 placeHolderNamesTc = emptyNameSet
 
-placeHolderHsWrapper :: PlaceHolder
-placeHolderHsWrapper = PlaceHolder
-
 {-
+TODO:AZ: remove this, and check if we still need all the UndecidableInstances
 
 Note [Pass sensitive types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs
index bbf45d7d0c..913ece0f27 100644
--- a/compiler/iface/BinFingerprint.hs
+++ b/compiler/iface/BinFingerprint.hs
@@ -10,6 +10,8 @@ module BinFingerprint
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Fingerprint
 import Binary
 import Name
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index f658d7f156..4e226854d6 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-}
+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
 
 --
 --  (c) The University of Glasgow 2002-2006
 --
 
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O2 #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -15,11 +15,16 @@ module BinIface (
         getSymtabName,
         getDictFastString,
         CheckHiWay(..),
-        TraceBinIFaceReading(..)
+        TraceBinIFaceReading(..),
+        getWithUserData,
+        putWithUserData
+
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnMonad
 import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
 import IfaceEnv
@@ -42,14 +47,18 @@ import FastString
 import Constants
 import Util
 
+import Data.Array
+import Data.Array.ST
+import Data.Array.Unsafe
 import Data.Bits
 import Data.Char
-import Data.List
 import Data.Word
-import Data.Array
 import Data.IORef
+import Data.Foldable
 import Control.Monad
-
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State.Strict as State
 
 -- ---------------------------------------------------------------------------
 -- Reading and writing binary interface files
@@ -128,7 +137,14 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
     wantedGot "Way" way_descr check_way
     when (checkHiWay == CheckHiWay) $
         errorOnMismatch "mismatched interface file ways" way_descr check_way
+    getWithUserData ncu bh
+
 
+-- | This performs a get action after reading the dictionary and symbol
+-- table. It is necessary to run this before trying to deserialise any
+-- Names or FastStrings.
+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
+getWithUserData ncu bh = do
     -- Read the dictionary
     -- The next word in the file is a pointer to where the dictionary is
     -- (probably at the end of the file)
@@ -173,6 +189,17 @@ writeBinIface dflags hi_path mod_iface = do
     let way_descr = getWayDescr dflags
     put_  bh way_descr
 
+
+    putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+    -- And send the result to the file
+    writeBinMem bh hi_path
+
+-- | Put a piece of data with an initialised `UserData` field. This
+-- is necessary if you want to serialise Names or FastStrings.
+-- It also writes a symbol table and the dictionary.
+-- This segment should be read using `getWithUserData`.
+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
+putWithUserData log_action bh payload = do
     -- Remember where the dictionary pointer will go
     dict_p_p <- tellBin bh
     -- Placeholder for ptr to dictionary
@@ -181,8 +208,7 @@ writeBinIface dflags hi_path mod_iface = do
     -- Remember where the symbol table pointer will go
     symtab_p_p <- tellBin bh
     put_ bh symtab_p_p
-
-    -- Make some intial state
+    -- Make some initial state
     symtab_next <- newFastMutInt
     writeFastMutInt symtab_next 0
     symtab_map <- newIORef emptyUFM
@@ -200,7 +226,7 @@ writeBinIface dflags hi_path mod_iface = do
     bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
                                                   (putName bin_dict bin_symtab)
                                                   (putFastString bin_dict)
-    put_ bh mod_iface
+    put_ bh payload
 
     -- Write the symtab pointer at the front of the file
     symtab_p <- tellBin bh        -- This is where the symtab will start
@@ -211,13 +237,13 @@ writeBinIface dflags hi_path mod_iface = do
     symtab_next <- readFastMutInt symtab_next
     symtab_map  <- readIORef symtab_map
     putSymbolTable bh symtab_next symtab_map
-    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
+    log_action (text "writeBinIface:" <+> int symtab_next
                                 <+> text "Names")
 
     -- NB. write the dictionary after the symbol table, because
     -- writing the symbol table may create more dictionary entries.
 
-    -- Write the dictionary pointer at the fornt of the file
+    -- Write the dictionary pointer at the front of the file
     dict_p <- tellBin bh          -- This is where the dictionary will start
     putAt bh dict_p_p dict_p      -- Fill in the placeholder
     seekBin bh dict_p             -- Seek back to the end of the file
@@ -226,11 +252,10 @@ writeBinIface dflags hi_path mod_iface = do
     dict_next <- readFastMutInt dict_next_ref
     dict_map  <- readIORef dict_map_ref
     putDictionary bh dict_next dict_map
-    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
+    log_action (text "writeBinIface:" <+> int dict_next
                                 <+> text "dict entries")
 
-    -- And send the result to the file
-    writeBinMem bh hi_path
+
 
 -- | Initial ram buffer to allocate for writing interface files
 initBinMemSize :: Int
@@ -259,15 +284,24 @@ getSymbolTable bh ncu = do
     sz <- get bh
     od_names <- sequence (replicate sz (get bh))
     updateNameCache ncu $ \namecache ->
-        let arr = listArray (0,sz-1) names
-            (namecache', names) =
-                mapAccumR (fromOnDiskName arr) namecache od_names
-        in (namecache', arr)
+        runST $ flip State.evalStateT namecache $ do
+            mut_arr <- lift $ newSTArray_ (0, sz-1)
+            for_ (zip [0..] od_names) $ \(i, odn) -> do
+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
+                lift $ writeArray mut_arr i n
+                State.put nc
+            arr <- lift $ unsafeFreeze mut_arr
+            namecache' <- State.get
+            return (namecache', arr)
+  where
+    -- This binding is required because the type of newArray_ cannot be inferred
+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
+    newSTArray_ = newArray_
 
 type OnDiskName = (UnitId, ModuleName, OccName)
 
-fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
+fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
+fromOnDiskName nc (pid, mod_name, occ) =
     let mod   = mkModule pid mod_name
         cache = nsNames nc
     in case lookupOrigNameCache cache  mod occ of
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 76b7793859..693e2899c8 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -6,15 +6,17 @@
 {-# LANGUAGE CPP #-}
 
 module BuildTyCl (
-        buildDataCon, mkDataConUnivTyVarBinders,
+        buildDataCon,
         buildPatSyn,
-        TcMethInfo, buildClass,
-        mkNewTyConRhs, mkDataTyConRhs,
+        TcMethInfo, MethInfo, buildClass,
+        mkNewTyConRhs,
         newImplicitBinder, newTyConRepName
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import IfaceEnv
 import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
 import TysWiredIn( isCTupleTyConName )
@@ -25,6 +27,7 @@ import Var
 import VarSet
 import BasicTypes
 import Name
+import NameEnv
 import MkId
 import Class
 import TyCon
@@ -39,19 +42,6 @@ import UniqSupply
 import Util
 import Outputable
 
-mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
-mkDataTyConRhs cons
-  = DataTyCon {
-        data_cons = cons,
-        is_enum = not (null cons) && all is_enum_con cons
-                  -- See Note [Enumeration types] in TyCon
-    }
-  where
-    is_enum_con con
-       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
-           <- dataConFullSig con
-       = null ex_tvs && null eq_spec && null theta && null arg_tys
-
 
 mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 -- ^ Monadic because it makes a Name for the coercion TyCon
@@ -70,9 +60,12 @@ mkNewTyConRhs tycon_name tycon con
   where
     tvs    = tyConTyVars tycon
     roles  = tyConRoles tycon
-    inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs)
-    rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
-        -- Instantiate the data con with the
+    con_arg_ty = case dataConRepArgTys con of
+                   [arg_ty] -> arg_ty
+                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
+    rhs_ty = substTyWith (dataConUnivTyVars con)
+                         (mkTyVarTys tvs) con_arg_ty
+        -- Instantiate the newtype's RHS with the
         -- type variables from the tycon
         -- NB: a newtype DataCon has a type that must look like
         --        forall tvs.  <arg-ty> -> T tvs
@@ -107,21 +100,25 @@ buildDataCon :: FamInstEnvs
             -> Maybe [HsImplBang]
                 -- See Note [Bangs on imported data constructors] in MkId
            -> [FieldLabel]             -- Field labels
-           -> [TyVarBinder]            -- Universals
-           -> [TyVarBinder]            -- Existentials
+           -> [TyVar]                  -- Universals
+           -> [TyCoVar]                -- Existentials
+           -> [TyVarBinder]            -- User-written 'TyVarBinder's
            -> [EqSpec]                 -- Equality spec
-           -> ThetaType                -- Does not include the "stupid theta"
+           -> KnotTied ThetaType       -- Does not include the "stupid theta"
                                        -- or the GADT equalities
-           -> [Type] -> Type           -- Argument and result types
-           -> TyCon                    -- Rep tycon
+           -> [KnotTied Type]          -- Arguments
+           -> KnotTied Type            -- Result types
+           -> KnotTied TyCon           -- Rep tycon
+           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
+                                       -- ConTag
            -> TcRnIf m n DataCon
 -- A wrapper for DataCon.mkDataCon that
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --      allocating its unique (hence monadic)
---   c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
-             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
+             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
+             rep_tycon tag_map
   = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
         ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
         -- This last one takes the name of the data constructor in the source
@@ -132,10 +129,12 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
         ; us <- newUniqueSupply
         ; dflags <- getDynFlags
         ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+              tag = lookupNameEnv_NF tag_map src_name
+              -- See Note [Constructor tag allocation], fixes #14657
               data_con = mkDataCon src_name declared_infix prom_info
                                    src_bangs field_lbls
-                                   univ_tvs ex_tvs eq_spec ctxt
-                                   arg_tys res_ty NoRRI rep_tycon
+                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
+                                   arg_tys res_ty NoRRI rep_tycon tag
                                    stupid_ctxt dc_wrk dc_rep
               dc_wrk = mkDataConWorkId work_name data_con
               dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
@@ -149,13 +148,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
 -- the type variables mentioned in the arg_tys
 -- ToDo: Or functionally dependent on?
 --       This whole stupid theta thing is, well, stupid.
-mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
 mkDataConStupidTheta tycon arg_tys univ_tvs
   | null stupid_theta = []      -- The common case
   | otherwise         = filter in_arg_tys stupid_theta
   where
     tc_subst     = zipTvSubst (tyConTyVars tycon)
-                              (mkTyVarTys (binderVars univ_tvs))
+                              (mkTyVarTys univ_tvs)
     stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
         -- Start by instantiating the master copy of the
         -- stupid theta, taken from the TyCon
@@ -165,69 +164,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
                       tyCoVarsOfType pred `intersectVarSet` arg_tyvars
 
 
-mkDataConUnivTyVarBinders :: [TyConBinder]   -- From the TyCon
-                          -> [TyVarBinder]   -- For the DataCon
--- See Note [Building the TyBinders for a DataCon]
-mkDataConUnivTyVarBinders tc_bndrs
- = map mk_binder tc_bndrs
- where
-   mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv
-      where
-        vis = case tc_vis of
-                AnonTCB           -> Specified
-                NamedTCB Required -> Specified
-                NamedTCB vis      -> vis
-
-{- Note [Building the TyBinders for a DataCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A DataCon needs to keep track of the visibility of its universals and
-existentials, so that visible type application can work properly. This
-is done by storing the universal and existential TyVarBinders.
-See Note [TyVarBinders in DataCons] in DataCon.
-
-During construction of a DataCon, we often start from the TyBinders of
-the parent TyCon.  For example
-   data Maybe a = Nothing | Just a
-The DataCons start from the TyBinders of the parent TyCon.
-
-But the ultimate TyBinders for the DataCon are *different* than those
-of the DataCon. Here is an example:
-
-  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
-
-The TyCon has
-
-  tyConTyVars    = [ k:*,                              a:k->*,      b:k]
-  tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ]
-
-The TyBinders for App line up with App's kind, given above.
-
-But the DataCon MkApp has the type
-  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
-
-That is, its TyBinders should be
-
-  dataConUnivTyVarBinders = [ TvBndr (k:*)    Inferred
-                            , TvBndr (a:k->*) Specified
-                            , TvBndr (b:k)    Specified ]
-
-So we want to take the TyCon's TyBinders and the TyCon's TyVars and
-merge them, pulling
-  - variable names from the TyVars
-  - visibilities from the TyBinders
-  - but changing Anon/Required to Specified
-
-The last part about Required->Specified comes from this:
-  data T k (a:k) b = MkT (a b)
-Here k is Required in T's kind, but we don't have Required binders in
-the TyBinders for a term (see Note [No Required TyBinder in terms]
-in TyCoRep), so we change it to Specified when making MkT's TyBinders
-
-This merging operation is done by mkDataConUnivTyBinders. In contrast,
-the TyBinders passed to mkDataCon are the final TyBinders stored in the
-DataCon (mkDataCon does no further work).
--}
-
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
             -> (Id,Bool) -> Maybe (Id, Bool)
@@ -278,7 +214,8 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
 
 
 ------------------------------------------------------
-type TcMethInfo     -- A temporary intermediate, to communicate
+type TcMethInfo = MethInfo  -- this variant needs zonking
+type MethInfo       -- A temporary intermediate, to communicate
                     -- between tcClassSigs and buildClass.
   = ( Name   -- Name of the class op
     , Type   -- Type of the class op
@@ -302,7 +239,7 @@ buildClass :: Name  -- Name of the class/tycon (they have the same Name)
            -> [FunDep TyVar]               -- Functional dependencies
            -- Super classes, associated types, method info, minimal complete def.
            -- This is Nothing if the class is abstract.
-           -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
+           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
            -> TcRnIf m n Class
 
 buildClass tycon_name binders roles fds Nothing
@@ -310,7 +247,7 @@ buildClass tycon_name binders roles fds Nothing
     do  { traceIf (text "buildClass")
 
         ; tc_rep_name  <- newTyConRepName tycon_name
-        ; let univ_bndrs = mkDataConUnivTyVarBinders binders
+        ; let univ_bndrs = tyConTyVarBinders binders
               univ_tvs   = binderVars univ_bndrs
               tycon = mkClassTyCon tycon_name binders roles
                                    AbstractTyCon rec_clas tc_rep_name
@@ -359,7 +296,7 @@ buildClass tycon_name binders roles fds
               op_names   = [op | (op,_,_) <- sig_stuff]
               arg_tys    = sc_theta ++ op_tys
               rec_tycon  = classTyCon rec_clas
-              univ_bndrs = mkDataConUnivTyVarBinders binders
+              univ_bndrs = tyConTyVarBinders binders
               univ_tvs   = binderVars univ_bndrs
 
         ; rep_nm   <- newTyConRepName datacon_name
@@ -370,13 +307,15 @@ buildClass tycon_name binders roles fds
                                    (map (const no_bang) args)
                                    (Just (map (const HsLazy) args))
                                    [{- No fields -}]
-                                   univ_bndrs
+                                   univ_tvs
                                    [{- no existentials -}]
+                                   univ_bndrs
                                    [{- No GADT equalities -}]
                                    [{- No theta -}]
                                    arg_tys
                                    (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
                                    rec_tycon
+                                   (mkTyConTagMap rec_tycon)
 
         ; rhs <- case () of
                   _ | use_newtype
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
index fd0459d6cc..2ef369a5e9 100644
--- a/compiler/iface/FlagChecker.hs
+++ b/compiler/iface/FlagChecker.hs
@@ -4,8 +4,12 @@
 -- interface file as part of the recompilation checking infrastructure.
 module FlagChecker (
         fingerprintDynFlags
+      , fingerprintOptFlags
+      , fingerprintHpcFlags
     ) where
 
+import GhcPrelude
+
 import Binary
 import BinIface ()
 import DynFlags
@@ -42,8 +46,11 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
                 map fromEnum $ EnumSet.toList extensionFlags)
 
         -- -I, -D and -U flags affect CPP
-        cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags)
+        cpp = ( map normalise $ flattenIncludes includePaths
             -- normalise: eliminate spurious differences due to "./foo" vs "foo"
+              , picPOpts dflags
+              , opt_P_signature dflags)
+            -- See Note [Repeated -optP hashing]
 
         -- Note [path flags and recompilation]
         paths = [ hcSuf ]
@@ -51,25 +58,45 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
         -- -fprof-auto etc.
         prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0
 
-        -- -O, see https://ghc.haskell.org/trac/ghc/ticket/10923
-        opt = if hscTarget == HscInterpreted ||
-                 hscTarget == HscNothing
-                 then 0
-                 else optLevel
+        flags = (mainis, safeHs, lang, cpp, paths, prof)
+
+    in -- pprTrace "flags" (ppr flags) $
+       computeFingerprint nameio flags
 
+-- Fingerprint the optimisation info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to ignore changes in
+-- optimisation level or optimisation flags so as to use as many pre-existing
+-- object files as they can.
+-- See Note [Ignoring some flag changes]
+fingerprintOptFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintOptFlags DynFlags{..} nameio =
+      let
+        -- See https://ghc.haskell.org/trac/ghc/ticket/10923
+        -- We used to fingerprint the optimisation level, but as Joachim
+        -- Breitner pointed out in comment 9 on that ticket, it's better
+        -- to ignore that and just look at the individual optimisation flags.
+        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
+                                          (EnumSet.toList generalFlags)
+
+      in computeFingerprint nameio opt_flags
+
+-- Fingerprint the HPC info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to use an object
+-- file compiled for HPC when not actually using HPC.
+-- See Note [Ignoring some flag changes]
+fingerprintHpcFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintHpcFlags dflags@DynFlags{..} nameio =
+      let
         -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798
         -- hpcDir is output-only, so we should recompile if it changes
         hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
 
-        -- -fignore-asserts, which affects how `Control.Exception.assert` works
-        ignore_asserts = gopt Opt_IgnoreAsserts dflags
+      in computeFingerprint nameio hpc
 
-        -- Nesting just to avoid ever more Binary tuple instances
-        flags = (mainis, safeHs, lang, cpp, paths,
-                 (prof, opt, hpc, ignore_asserts))
-
-    in -- pprTrace "flags" (ppr flags) $
-       computeFingerprint nameio flags
 
 {- Note [path flags and recompilation]
 
@@ -100,3 +127,55 @@ recompilation check; here we explain why.
 
 The only path-related flag left is -hcsuf.
 -}
+
+{- Note [Ignoring some flag changes]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Normally, --make tries to reuse only compilation products that are
+the same as those that would have been produced compiling from
+scratch. Sometimes, however, users would like to be more aggressive
+about recompilation avoidance. This is particularly likely when
+developing using GHCi (see #13604). Currently, we allow users to
+ignore optimisation changes using -fignore-optim-changes, and to
+ignore HPC option changes using -fignore-hpc-changes. If there's a
+demand for it, we could also allow changes to -fprof-auto-* flags
+(although we can't allow -prof flags to differ). The key thing about
+these options is that we can still successfully link a library or
+executable when some of its components differ in these ways.
+
+The way we accomplish this is to leave the optimization and HPC
+options out of the flag hash, hashing them separately.
+-}
+
+{- Note [Repeated -optP hashing]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We invoke fingerprintDynFlags for each compiled module to include
+the hash of relevant DynFlags in the resulting interface file.
+-optP (preprocessor) flags are part of that hash.
+-optP flags can come from multiple places:
+
+  1. -optP flags directly passed on command line.
+  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
+  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.
+
+When compiling many modules at once with many -optP command line arguments
+the work of hashing -optP flags would be repeated. This can get expensive
+and as noted on #14697 it can take 7% of time and 14% of allocations on
+a real codebase.
+
+The obvious solution is to cache the hash of -optP flags per GHC invocation.
+However, one has to be careful there, as the flags that were added in 3. way
+have to be accounted for.
+
+The current strategy is as follows:
+
+  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
+     is modified. This serves dual purpose. It ensures correctness for when
+     we add per file -optP flags and lets us save work for when we don't.
+  2. When computing the fingerprint in fingerprintDynFlags use the cached
+     value *and* fingerprint the additional implied (see 2. above) -optP flags.
+     This is relatively cheap and saves the headache of fingerprinting all
+     the -optP flags and tracking all the places that could invalidate the
+     cache.
+-}
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index f66ebdc321..864c09ce2e 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -1,12 +1,12 @@
 -- (c) The University of Glasgow 2002-2006
 
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
 
 module IfaceEnv (
         newGlobalBinder, newInteractiveBinder,
         externaliseName,
         lookupIfaceTop,
-        lookupOrig, lookupOrigNameCache, extendNameCache,
+        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
         newIfaceName, newIfaceNames,
         extendIfaceIdEnv, extendIfaceTyVarEnv,
         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
@@ -16,12 +16,14 @@ module IfaceEnv (
         ifaceExportNames,
 
         -- Name-cache stuff
-        allocateGlobalBinder, updNameCache,
+        allocateGlobalBinder, updNameCacheTc,
         mkNameCacheUpdater, NameCacheUpdater(..),
    ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnMonad
 import HscTypes
 import Type
@@ -59,8 +61,7 @@ newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
 -- moment when we know its Module and SrcLoc in their full glory
 
 newGlobalBinder mod occ loc
-  = do { mod `seq` occ `seq` return ()    -- See notes with lookupOrig
-       ; name <- updNameCache $ \name_cache ->
+  = do { name <- updNameCacheTc mod occ $ \name_cache ->
                  allocateGlobalBinder name_cache mod occ loc
        ; traceIf (text "newGlobalBinder" <+>
                   (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
@@ -71,7 +72,7 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
 -- from the interactive context
 newInteractiveBinder hsc_env occ loc
  = do { let mod = icInteractiveModule (hsc_IC hsc_env)
-       ; updNameCacheIO hsc_env $ \name_cache ->
+       ; updNameCacheIO hsc_env mod occ $ \name_cache ->
          allocateGlobalBinder name_cache mod occ loc }
 
 allocateGlobalBinder
@@ -128,11 +129,31 @@ newtype NameCacheUpdater
 
 mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
 mkNameCacheUpdater = do { hsc_env <- getTopEnv
-                        ; return (NCU (updNameCacheIO hsc_env)) }
+                        ; let !ncRef = hsc_NC hsc_env
+                        ; return (NCU (updNameCache ncRef)) }
+
+updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
+               -> TcRnIf a b c
+updNameCacheTc mod occ upd_fn = do {
+    hsc_env <- getTopEnv
+  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
+
+
+updNameCacheIO ::  HscEnv -> Module -> OccName
+               -> (NameCache -> (NameCache, c))
+               -> IO c
+updNameCacheIO hsc_env mod occ upd_fn = do {
+
+    -- First ensure that mod and occ are evaluated
+    -- If not, chaos can ensue:
+    --      we read the name-cache
+    --      then pull on mod (say)
+    --      which does some stuff that modifies the name cache
+    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+
+    mod `seq` occ `seq` return ()
+  ; updNameCache (hsc_NC hsc_env) upd_fn }
 
-updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
-updNameCache upd_fn = do { hsc_env <- getTopEnv
-                         ; liftIO $ updNameCacheIO hsc_env upd_fn }
 
 {-
 ************************************************************************
@@ -147,26 +168,31 @@ updNameCache upd_fn = do { hsc_env <- getTopEnv
 -- and 'Module' is simply that of the 'ModIface' you are typechecking.
 lookupOrig :: Module -> OccName -> TcRnIf a b Name
 lookupOrig mod occ
-  = do  {       -- First ensure that mod and occ are evaluated
-                -- If not, chaos can ensue:
-                --      we read the name-cache
-                --      then pull on mod (say)
-                --      which does some stuff that modifies the name cache
-                -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
-          mod `seq` occ `seq` return ()
-        ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
-
-        ; updNameCache $ \name_cache ->
-          case lookupOrigNameCache (nsNames name_cache) mod occ of {
-              Just name -> (name_cache, name);
-              Nothing   ->
-              case takeUniqFromSupply (nsUniqs name_cache) of {
-              (uniq, us) ->
-                  let
-                    name      = mkExternalName uniq mod occ noSrcSpan
-                    new_cache = extendNameCache (nsNames name_cache) mod occ name
-                  in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
-    }}}
+  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
+
+        ; updNameCacheTc mod occ $ lookupNameCache mod occ }
+
+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
+lookupOrigIO hsc_env mod occ
+  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ name_cache =
+  case lookupOrigNameCache (nsNames name_cache) mod occ of {
+    Just name -> (name_cache, name);
+    Nothing   ->
+        case takeUniqFromSupply (nsUniqs name_cache) of {
+          (uniq, us) ->
+              let
+                name      = mkExternalName uniq mod occ noSrcSpan
+                new_cache = extendNameCache (nsNames name_cache) mod occ name
+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
 
 externaliseName :: Module -> Name -> TcRnIf m n Name
 -- Take an Internal Name and make it an External one,
@@ -176,7 +202,7 @@ externaliseName mod name
              loc = nameSrcSpan name
              uniq = nameUnique name
        ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
-       ; updNameCache $ \ ns ->
+       ; updNameCacheTc mod occ $ \ ns ->
          let name' = mkExternalName uniq mod occ loc
              ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
          in (ns', name') }
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 60206ea076..3266c5aec1 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -41,6 +41,8 @@ module IfaceSyn (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import IfaceType
 import BinFingerprint
 import CoreSyn( IsOrphan, isOrphan )
@@ -62,9 +64,9 @@ import SrcLoc
 import Fingerprint
 import Binary
 import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
-import Var( TyVarBndr(..) )
+import Var( VarBndr(..) )
 import TyCon ( Role (..), Injectivity(..) )
-import Util( filterOut, filterByList )
+import Util( dropList, filterByList )
 import DataCon (SrcStrictness(..), SrcUnpackedness(..))
 import Lexeme (isLexSym)
 import DynFlags
@@ -85,7 +87,7 @@ infixl 3 &&&
 -- | A binding top-level 'Name' in an interface file (e.g. the name of an
 -- 'IfaceDecl').
 type IfaceTopBndr = Name
-  -- It's convenient to have an Name in the IfaceSyn, although in each
+  -- It's convenient to have a Name in the IfaceSyn, although in each
   -- case the namespace is implied by the context. However, having an
   -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints
   -- very convenient. Moreover, having the key of the binder means that
@@ -180,9 +182,11 @@ data IfaceClassBody
 
 data IfaceTyConParent
   = IfNoParent
-  | IfDataInstance IfExtName
-                   IfaceTyCon
-                   IfaceTcArgs
+  | IfDataInstance
+       IfExtName     -- Axiom name
+       IfaceTyCon    -- Family TyCon (pretty-printing only, not used in TcIface)
+                     -- see Note [Pretty printing via IfaceSyn] in PprTyThing
+       IfaceAppArgs  -- Arguments of the family TyCon
 
 data IfaceFamTyConFlav
   = IfaceDataFamilyTyCon                      -- Data family
@@ -190,6 +194,7 @@ data IfaceFamTyConFlav
   | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
     -- ^ Name of associated axiom and branches for pretty printing purposes,
     -- or 'Nothing' for an empty closed family without an axiom
+    -- See Note [Pretty printing via IfaceSyn] in PprTyThing
   | IfaceAbstractClosedSynFamilyTyCon
   | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
 
@@ -209,7 +214,7 @@ data IfaceAT = IfaceAT  -- See Class.ClassATItem
 -- This is just like CoAxBranch
 data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars   :: [IfaceTvBndr]
                                    , ifaxbCoVars   :: [IfaceIdBndr]
-                                   , ifaxbLHS      :: IfaceTcArgs
+                                   , ifaxbLHS      :: IfaceAppArgs
                                    , ifaxbRoles    :: [Role]
                                    , ifaxbRHS      :: IfaceType
                                    , ifaxbIncomps  :: [BranchIndex] }
@@ -238,7 +243,14 @@ data IfaceConDecl
         -- but it's not so easy for the original TyCon/DataCon
         -- So this guarantee holds for IfaceConDecl, but *not* for DataCon
 
-        ifConExTvs   :: [IfaceForAllBndr],  -- Existential tyvars (w/ visibility)
+        ifConExTCvs   :: [IfaceBndr],  -- Existential ty/covars
+        ifConUserTvBinders :: [IfaceForAllBndr],
+          -- The tyvars, in the order the user wrote them
+          -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the
+          --            set of tyvars (*not* covars) of ifConExTCvs, unioned
+          --            with the set of ifBinders (from the parent IfaceDecl)
+          --            whose tyvars do not appear in ifConEqSpec
+          -- See Note [DataCon user type variable binders] in DataCon
         ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
         ifConCtxt    :: IfaceContext,       -- Non-stupid context
         ifConArgTys  :: [IfaceType],        -- Arg types
@@ -564,7 +576,7 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
       | otherwise
       = brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+>
                   pprWithCommas pprIfaceIdBndr cvs)
-    pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
+    pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys)
     maybe_incomps = ppUnless (null incomps) $ parens $
                     text "incompatible indices:" <+> ppr incomps
 
@@ -691,26 +703,28 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
 -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
 --     See Note [Pretty-printing TyThings] in PprTyThing
 pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
-                             ifCtxt = context,
+                             ifCtxt = context, ifResKind = kind,
                              ifRoles = roles, ifCons = condecls,
                              ifParent = parent,
                              ifGadtSyntax = gadt,
                              ifBinders = binders })
 
-  | gadt_style = vcat [ pp_roles
-                      , pp_nd <+> pp_lhs <+> pp_where
-                      , nest 2 (vcat pp_cons)
-                      , nest 2 $ ppShowIface ss pp_extra ]
-  | otherwise  = vcat [ pp_roles
-                      , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
-                      , nest 2 $ ppShowIface ss pp_extra ]
+  | gadt      = vcat [ pp_roles
+                     , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where
+                     , nest 2 (vcat pp_cons)
+                     , nest 2 $ ppShowIface ss pp_extra ]
+  | otherwise = vcat [ pp_roles
+                     , hang (pp_nd <+> pp_lhs <+> pp_kind) 2 (add_bars pp_cons)
+                     , nest 2 $ ppShowIface ss pp_extra ]
   where
     is_data_instance = isIfaceDataInstance parent
 
-    gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
     cons       = visibleIfConDecls condecls
-    pp_where   = ppWhen (gadt_style && not (null cons)) $ text "where"
+    pp_where   = ppWhen (gadt && not (null cons)) $ text "where"
     pp_cons    = ppr_trim (map show_con cons) :: [SDoc]
+    pp_kind
+      | isIfaceLiftedTypeKind kind = empty
+      | otherwise = dcolon <+> ppr kind
 
     pp_lhs = case parent of
                IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
@@ -732,7 +746,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
 
     show_con dc
-      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc
+      | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc
       | otherwise = Nothing
 
     pp_nd = case condecls of
@@ -851,11 +865,13 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
   = sdocWithDynFlags mk_msg
   where
     mk_msg dflags
-      = hsep [ text "pattern", pprPrefixOcc name, dcolon
-             , univ_msg, pprIfaceContextArr req_ctxt
-             , ppWhen insert_empty_ctxt $ parens empty <+> darrow
-             , ex_msg, pprIfaceContextArr prov_ctxt
-             , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
+      = hang (text "pattern" <+> pprPrefixOcc name)
+           2 (dcolon <+> sep [univ_msg
+                             , pprIfaceContextArr req_ctxt
+                             , ppWhen insert_empty_ctxt $ parens empty <+> darrow
+                             , ex_msg
+                             , pprIfaceContextArr prov_ctxt
+                             , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys ])
       where
         univ_msg = pprUserIfaceForAll univ_bndrs
         ex_msg   = pprUserIfaceForAll ex_bndrs
@@ -940,7 +956,7 @@ pprIfaceTyConParent IfNoParent
 pprIfaceTyConParent (IfDataInstance _ tc tys)
   = sdocWithDynFlags $ \dflags ->
     let ftys = stripInvisArgs dflags tys
-    in pprIfaceTypeApp TopPrec tc ftys
+    in pprIfaceTypeApp topPrec tc ftys
 
 pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name
                  -> [IfaceTyConBinder]   -- of the tycon, for invisible-suppression
@@ -953,12 +969,6 @@ pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
           <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
         , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
 
-isVanillaIfaceConDecl :: IfaceConDecl -> Bool
-isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
-                             , ifConEqSpec = eq_spec
-                             , ifConCtxt   = ctxt })
-  = (null ex_tvs) && (null eq_spec) && (null ctxt)
-
 pprIfaceConDecl :: ShowSub -> Bool
                 -> IfaceTopBndr
                 -> [IfaceTyConBinder]
@@ -966,37 +976,46 @@ pprIfaceConDecl :: ShowSub -> Bool
                 -> IfaceConDecl -> SDoc
 pprIfaceConDecl ss gadt_style tycon tc_binders parent
         (IfCon { ifConName = name, ifConInfix = is_infix,
-                 ifConExTvs = ex_tvs,
+                 ifConUserTvBinders = user_tvbs,
                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
                  ifConStricts = stricts, ifConFields = fields })
-  | gadt_style            = pp_prefix_con <+> dcolon <+> ppr_ty
-  | not (null fields)     = pp_prefix_con <+> pp_field_args
-  | is_infix
-  , [ty1, ty2] <- pp_args = sep [ ty1
-                                , pprInfixIfDeclBndr how_much (occName name)
-                                , ty2]
-
-  | otherwise             = pp_prefix_con <+> sep pp_args
+  | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty
+  | otherwise  = ppr_ex_quant pp_h98_con
   where
+    pp_h98_con
+      | not (null fields) = pp_prefix_con <+> pp_field_args
+      | is_infix
+      , [ty1, ty2] <- pp_args
+      = sep [ ty1
+            , pprInfixIfDeclBndr how_much (occName name)
+            , ty2]
+      | otherwise = pp_prefix_con <+> sep pp_args
+
     how_much = ss_how_much ss
     tys_w_strs :: [(IfaceBang, IfaceType)]
     tys_w_strs = zip stricts arg_tys
     pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)
 
-    (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
-    ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
-                                ctxt pp_tau
+    -- If we're pretty-printing a H98-style declaration with existential
+    -- quantification, then user_tvbs will always consist of the universal
+    -- tyvar binders followed by the existential tyvar binders. So to recover
+    -- the visibilities of the existential tyvar binders, we can simply drop
+    -- the universal tyvar binders from user_tvbs.
+    ex_tvbs = dropList tc_binders user_tvbs
+    ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt
+    pp_gadt_res_ty = mk_user_con_res_ty eq_spec
+    ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau
 
         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
         -- because we don't have a Name for the tycon, only an OccName
     pp_tau | null fields
-           = case pp_args ++ [pp_res_ty] of
+           = case pp_args ++ [pp_gadt_res_ty] of
                 (t:ts) -> fsep (t : map (arrow <+>) ts)
                 []     -> panic "pp_con_taus"
            | otherwise
-           = sep [pp_field_args, arrow <+> pp_res_ty]
+           = sep [pp_field_args, arrow <+> pp_gadt_res_ty]
 
-    ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'
+    ppr_bang IfNoBang = whenPprDebug $ char '_'
     ppr_bang IfStrict = char '!'
     ppr_bang IfUnpack = text "{-# UNPACK #-}"
     ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
@@ -1030,23 +1049,24 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
         sel = flSelector lbl
         occ = mkVarOccFS (flLabel lbl)
 
-    mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
+    mk_user_con_res_ty :: IfaceEqSpec -> SDoc
     -- See Note [Result type of a data family GADT]
     mk_user_con_res_ty eq_spec
       | IfDataInstance _ tc tys <- parent
-      = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
+      = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys))
       | otherwise
-      = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
+      = sdocWithDynFlags (ppr_tc_app gadt_subst)
       where
         gadt_subst = mkIfaceTySubst eq_spec
-        con_univ_tvs = filterOut (inDomIfaceTySubst gadt_subst) $
-                       map ifTyConBinderTyVar tc_binders
 
     ppr_tc_app gadt_subst dflags
        = pprPrefixIfDeclBndr how_much (occName tycon)
          <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
-                 | (tv,_kind)
-                     <- map ifTyConBinderTyVar $
+                 | IfaceTvBndr (tv,_kind)
+                   -- Coercions variables are invisible, see Note
+                   -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+                   -- in TyCoRep
+                     <- map (ifTyConBinderVar) $
                         suppressIfaceInvisibles dflags tc_binders tc_binders ]
 
 instance Outputable IfaceRule where
@@ -1082,9 +1102,6 @@ ppr_rough :: Maybe IfaceTyCon -> SDoc
 ppr_rough Nothing   = dot
 ppr_rough (Just tc) = ppr tc
 
-tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
-tv_to_forall_bndr tv = TvBndr tv Specified
-
 {-
 Note [Result type of a data family GADT]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1276,7 +1293,7 @@ freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i})
 
 freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
                            , ifParent = p, ifCtxt = ctxt, ifCons = cons })
-  = freeNamesIfTyVarBndrs bndrs &&&
+  = freeNamesIfVarBndrs bndrs &&&
     freeNamesIfType res_k &&&
     freeNamesIfaceTyConParent p &&&
     freeNamesIfContext ctxt &&&
@@ -1284,18 +1301,18 @@ freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
 
 freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k
                               , ifSynRhs = rhs })
-  = freeNamesIfTyVarBndrs bndrs &&&
+  = freeNamesIfVarBndrs bndrs &&&
     freeNamesIfKind res_k &&&
     freeNamesIfType rhs
 
 freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k
                              , ifFamFlav = flav })
-  = freeNamesIfTyVarBndrs bndrs &&&
+  = freeNamesIfVarBndrs bndrs &&&
     freeNamesIfKind res_k &&&
     freeNamesIfFamFlav flav
 
 freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body })
-  = freeNamesIfTyVarBndrs bndrs &&&
+  = freeNamesIfVarBndrs bndrs &&&
     freeNamesIfClassBody cls_body
 
 freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches })
@@ -1313,8 +1330,8 @@ freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _)
                              , ifFieldLabels = lbls })
   = unitNameSet matcher &&&
     maybe emptyNameSet (unitNameSet . fst) mb_builder &&&
-    freeNamesIfTyVarBndrs univ_bndrs &&&
-    freeNamesIfTyVarBndrs ex_bndrs &&&
+    freeNamesIfVarBndrs univ_bndrs &&&
+    freeNamesIfVarBndrs ex_bndrs &&&
     freeNamesIfContext prov_ctxt &&&
     freeNamesIfContext req_ctxt &&&
     fnList freeNamesIfType args &&&
@@ -1336,7 +1353,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars   = tyvars
                                    , ifaxbRHS      = rhs })
   = fnList freeNamesIfTvBndr tyvars &&&
     fnList freeNamesIfIdBndr covars &&&
-    freeNamesIfTcArgs lhs &&&
+    freeNamesIfAppArgs lhs &&&
     freeNamesIfType rhs
 
 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
@@ -1377,12 +1394,12 @@ freeNamesIfConDecls (IfNewTyCon  c) = freeNamesIfConDecl c
 freeNamesIfConDecls _                   = emptyNameSet
 
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
-freeNamesIfConDecl (IfCon { ifConExTvs   = ex_tvs, ifConCtxt = ctxt
+freeNamesIfConDecl (IfCon { ifConExTCvs  = ex_tvs, ifConCtxt = ctxt
                           , ifConArgTys  = arg_tys
                           , ifConFields  = flds
                           , ifConEqSpec  = eq_spec
                           , ifConStricts = bangs })
-  = freeNamesIfTyVarBndrs ex_tvs &&&
+  = fnList freeNamesIfBndr ex_tvs &&&
     freeNamesIfContext ctxt &&&
     fnList freeNamesIfType arg_tys &&&
     mkNameSet (map flSelector flds) &&&
@@ -1396,26 +1413,32 @@ freeNamesIfBang _               = emptyNameSet
 freeNamesIfKind :: IfaceType -> NameSet
 freeNamesIfKind = freeNamesIfType
 
-freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
-freeNamesIfTcArgs (ITC_Vis   t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
-freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
-freeNamesIfTcArgs ITC_Nil          = emptyNameSet
+freeNamesIfAppArgs :: IfaceAppArgs -> NameSet
+freeNamesIfAppArgs (IA_Vis   t ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
+freeNamesIfAppArgs (IA_Invis k ks) = freeNamesIfKind k &&& freeNamesIfAppArgs ks
+freeNamesIfAppArgs IA_Nil          = emptyNameSet
 
 freeNamesIfType :: IfaceType -> NameSet
 freeNamesIfType (IfaceFreeTyVar _)    = emptyNameSet
 freeNamesIfType (IfaceTyVar _)        = emptyNameSet
-freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
-freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
-freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
+freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfAppArgs t
+freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
+freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
 freeNamesIfType (IfaceLitTy _)        = emptyNameSet
-freeNamesIfType (IfaceForAllTy tv t)  = freeNamesIfTyVarBndr tv &&& freeNamesIfType t
+freeNamesIfType (IfaceForAllTy tv t)  = freeNamesIfVarBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
 freeNamesIfType (IfaceDFunTy s t)     = freeNamesIfType s &&& freeNamesIfType t
 freeNamesIfType (IfaceCastTy t c)     = freeNamesIfType t &&& freeNamesIfCoercion c
 freeNamesIfType (IfaceCoercionTy c)   = freeNamesIfCoercion c
 
+freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
+freeNamesIfMCoercion IfaceMRefl    = emptyNameSet
+freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co
+
 freeNamesIfCoercion :: IfaceCoercion -> NameSet
-freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceGReflCo _ t mco)
+  = freeNamesIfType t &&& freeNamesIfMCoercion mco
 freeNamesIfCoercion (IfaceFunCo _ c1 c2)
   = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
 freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
@@ -1424,8 +1447,9 @@ freeNamesIfCoercion (IfaceAppCo c1 c2)
   = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
 freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
   = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
-freeNamesIfCoercion (IfaceCoVarCo _)
-  = emptyNameSet
+freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
+freeNamesIfCoercion (IfaceCoVarCo _)   = emptyNameSet
+freeNamesIfCoercion (IfaceHoleCo _)    = emptyNameSet
 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
   = unitNameSet ax &&& fnList freeNamesIfCoercion cos
 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
@@ -1440,8 +1464,6 @@ freeNamesIfCoercion (IfaceLRCo _ co)
   = freeNamesIfCoercion co
 freeNamesIfCoercion (IfaceInstCo co co2)
   = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
-freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
-  = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
 freeNamesIfCoercion (IfaceKindCo c)
   = freeNamesIfCoercion c
 freeNamesIfCoercion (IfaceSubCo co)
@@ -1455,13 +1477,12 @@ freeNamesIfProv IfaceUnsafeCoerceProv    = emptyNameSet
 freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co
 freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
 freeNamesIfProv (IfacePluginProv _)      = emptyNameSet
-freeNamesIfProv (IfaceHoleProv _)        = emptyNameSet
 
-freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet
-freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv
+freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
+freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
 
-freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet
-freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr
+freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet
+freeNamesIfVarBndrs = fnList freeNamesIfVarBndr
 
 freeNamesIfBndr :: IfaceBndr -> NameSet
 freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
@@ -1552,7 +1573,7 @@ freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
 freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
 freeNamesIfaceTyConParent IfNoParent = emptyNameSet
 freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
-  = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
+  = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
 
 -- helpers
 (&&&) :: NameSet -> NameSet -> NameSet
@@ -1865,7 +1886,7 @@ instance Binary IfaceConDecls where
             _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
 
 instance Binary IfaceConDecl where
-    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
         putIfaceTopBndr bh a1
         put_ bh a2
         put_ bh a3
@@ -1873,10 +1894,11 @@ instance Binary IfaceConDecl where
         put_ bh a5
         put_ bh a6
         put_ bh a7
-        put_ bh (length a8)
-        mapM_ (put_ bh) a8
-        put_ bh a9
+        put_ bh a8
+        put_ bh (length a9)
+        mapM_ (put_ bh) a9
         put_ bh a10
+        put_ bh a11
     get bh = do
         a1 <- getIfaceTopBndr bh
         a2 <- get bh
@@ -1885,11 +1907,12 @@ instance Binary IfaceConDecl where
         a5 <- get bh
         a6 <- get bh
         a7 <- get bh
+        a8 <- get bh
         n_fields <- get bh
-        a8 <- replicateM n_fields (get bh)
-        a9 <- get bh
+        a9 <- replicateM n_fields (get bh)
         a10 <- get bh
-        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+        a11 <- get bh
+        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
 
 instance Binary IfaceBang where
     put_ bh IfNoBang        = putByte bh 0
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 39e30283db..23b09dab7a 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -14,28 +14,30 @@ module IfaceType (
         IfExtName, IfLclName,
 
         IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
+        IfaceMCoercion(..),
         IfaceUnivCoProv(..),
         IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
-        IfaceTyLit(..), IfaceTcArgs(..),
+        IfaceTyLit(..), IfaceAppArgs(..),
         IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
         IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
 
-        ifTyConBinderTyVar, ifTyConBinderName,
+        ifForAllBndrVar, ifForAllBndrName,
+        ifTyConBinderVar, ifTyConBinderName,
 
         -- Equality testing
         isIfaceLiftedTypeKind,
 
-        -- Conversion from IfaceTcArgs -> [IfaceType]
-        tcArgsIfaceTypes,
+        -- Conversion from IfaceAppArgs -> [IfaceType]
+        appArgsIfaceTypes,
 
         -- Printing
         pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
         pprIfaceContext, pprIfaceContextArr,
         pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
-        pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
-        pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
-        pprIfaceTyLit,
+        pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs,
+        pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
+        pprIfaceSigmaType, pprIfaceTyLit,
         pprIfaceCoercion, pprParendIfaceCoercion,
         splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
         pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
@@ -44,12 +46,16 @@ module IfaceType (
         stripIfaceInvisVars,
         stripInvisArgs,
 
-        mkIfaceTySubst, substIfaceTyVar, substIfaceTcArgs, inDomIfaceTySubst
+        mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
+import GhcPrelude
+
+import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon
+                                 , liftedRepDataConTyCon )
+import {-# SOURCE #-} TyCoRep    ( isRuntimeRepTy )
 
 import DynFlags
 import TyCon hiding ( pprPromotionQuote )
@@ -65,7 +71,7 @@ import FastStringEnv
 import Util
 
 import Data.Maybe( isJust )
-import Data.List (foldl')
+import qualified Data.Semigroup as Semi
 
 {-
 ************************************************************************
@@ -90,6 +96,13 @@ type IfaceTvBndr  = (IfLclName, IfaceKind)
 ifaceTvBndrName :: IfaceTvBndr -> IfLclName
 ifaceTvBndrName (n,_) = n
 
+ifaceIdBndrName :: IfaceIdBndr -> IfLclName
+ifaceIdBndrName (n,_) = n
+
+ifaceBndrName :: IfaceBndr -> IfLclName
+ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr
+ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr
+
 type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
 
 data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy
@@ -108,23 +121,30 @@ data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy
 -------------------------------
 type IfaceKind     = IfaceType
 
-data IfaceType     -- A kind of universal type, used for types and kinds
-  = IfaceFreeTyVar TyVar                 -- See Note [Free tyvars in IfaceType]
+-- | A kind of universal type, used for types and kinds.
+--
+-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
+-- before being printed. See Note [Pretty printing via IfaceSyn] in PprTyThing
+data IfaceType
+  = IfaceFreeTyVar TyVar                -- See Note [Free tyvars in IfaceType]
   | IfaceTyVar     IfLclName            -- Type/coercion variable only, not tycon
   | IfaceLitTy     IfaceTyLit
-  | IfaceAppTy     IfaceType IfaceType
+  | IfaceAppTy     IfaceType IfaceAppArgs
+                             -- See Note [Suppressing invisible arguments] for
+                             -- an explanation of why the second field isn't
+                             -- IfaceType, analogous to AppTy.
   | IfaceFunTy     IfaceType IfaceType
   | IfaceDFunTy    IfaceType IfaceType
   | IfaceForAllTy  IfaceForAllBndr IfaceType
-  | IfaceTyConApp  IfaceTyCon IfaceTcArgs  -- Not necessarily saturated
-                                           -- Includes newtypes, synonyms, tuples
+  | IfaceTyConApp  IfaceTyCon IfaceAppArgs  -- Not necessarily saturated
+                                            -- Includes newtypes, synonyms, tuples
   | IfaceCastTy     IfaceType IfaceCoercion
   | IfaceCoercionTy IfaceCoercion
 
   | IfaceTupleTy                  -- Saturated tuples (unsaturated ones use IfaceTyConApp)
        TupleSort                  -- What sort of tuple?
        IsPromoted                 -- A bit like IfaceTyCon
-       IfaceTcArgs                -- arity = length args
+       IfaceAppArgs               -- arity = length args
           -- For promoted data cons, the kind args are omitted
 
 type IfacePredType = IfaceType
@@ -135,25 +155,28 @@ data IfaceTyLit
   | IfaceStrTyLit FastString
   deriving (Eq)
 
-type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
-type IfaceForAllBndr  = TyVarBndr IfaceTvBndr ArgFlag
+type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
+type IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag
 
 -- See Note [Suppressing invisible arguments]
 -- We use a new list type (rather than [(IfaceType,Bool)], because
 -- it'll be more compact and faster to parse in interface
 -- files. Rather than two bytes and two decisions (nil/cons, and
 -- type/kind) there'll just be one.
-data IfaceTcArgs
-  = ITC_Nil
-  | ITC_Vis   IfaceType IfaceTcArgs   -- "Vis" means show when pretty-printing
-  | ITC_Invis IfaceKind IfaceTcArgs   -- "Invis" means don't show when pretty-printing
+data IfaceAppArgs
+  = IA_Nil
+  | IA_Vis   IfaceType IfaceAppArgs   -- "Vis" means show when pretty-printing
+  | IA_Invis IfaceKind IfaceAppArgs   -- "Invis" means don't show when pretty-printing
                                       --         except with -fprint-explicit-kinds
 
-instance Monoid IfaceTcArgs where
-  mempty = ITC_Nil
-  ITC_Nil `mappend` xs           = xs
-  ITC_Vis ty rest `mappend` xs   = ITC_Vis ty (rest `mappend` xs)
-  ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs)
+instance Semi.Semigroup IfaceAppArgs where
+  IA_Nil <> xs           = xs
+  IA_Vis ty rest <> xs   = IA_Vis ty (rest Semi.<> xs)
+  IA_Invis ki rest <> xs = IA_Invis ki (rest Semi.<> xs)
+
+instance Monoid IfaceAppArgs where
+  mempty = IA_Nil
+  mappend = (Semi.<>)
 
 -- Encodes type constructors, kind constructors,
 -- coercion constructors, the lot.
@@ -179,18 +202,20 @@ data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
                     | IfaceSumTyCon !Arity
                       -- ^ e.g. @(a | b | c)@
 
-                    | IfaceEqualityTyCon !Bool
-                      -- ^ a type equality. 'True' indicates kind-homogeneous.
-                      -- See Note [Equality predicates in IfaceType] for
-                      -- details.
+                    | IfaceEqualityTyCon
+                      -- ^ A heterogeneous equality TyCon
+                      --   (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon)
+                      -- that is actually being applied to two types
+                      -- of the same kind.  This affects pretty-printing
+                      -- only: see Note [Equality predicates in IfaceType]
                     deriving (Eq)
 
 {- Note [Free tyvars in IfaceType]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an
-IfaceType and pretty printing that.  This eliminates a lot of
-pretty-print duplication, and it matches what we do with
-pretty-printing TyThings.
+Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
+an IfaceType and pretty printing that.  This eliminates a lot of
+pretty-print duplication, and it matches what we do with pretty-
+printing TyThings. See Note [Pretty printing via IfaceSyn] in PprTyThing.
 
 It works fine for closed types, but when printing debug traces (e.g.
 when using -ddump-tc-trace) we print a lot of /open/ types.  These
@@ -204,28 +229,61 @@ Note that:
   to deserialise one.  IfaceFreeTyVar is used only in the "convert to IfaceType
   and then pretty-print" pipeline.
 
+We do the same for covars, naturally.
 
 Note [Equality predicates in IfaceType]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 GHC has several varieties of type equality (see Note [The equality types story]
-in TysPrim for details) which all must be rendered with different surface syntax
-during pretty-printing. Which syntax we use depends upon,
-
- 1. Which predicate tycon was used
- 2. Whether the types being compared are of the same kind.
-
-Unfortunately, determining (2) from an IfaceType isn't possible since we can't
-see through type synonyms. Consequently, we need to record whether the equality
-is homogeneous or not in IfaceTyConSort for the purposes of pretty-printing.
-
-Namely we handle these cases,
-
-    Predicate               Homogeneous        Heterogeneous
-    ----------------        -----------        -------------
-    eqTyCon                 ~                  N/A
-    heqTyCon                ~                  ~~
-    eqPrimTyCon             ~#                 ~~
-    eqReprPrimTyCon         Coercible          Coercible
+in TysPrim for details).  In an effort to avoid confusing users, we suppress
+the differences during pretty printing unless certain flags are enabled.
+Here is how each equality predicate* is printed in homogeneous and
+heterogeneous contexts, depending on which combination of the
+-fprint-explicit-kinds and -fprint-equality-relations flags is used:
+
+---------------------------------------------------------------------------------------
+|         Predicate             |        Neither flag        | -fprint-explicit-kinds |
+|-------------------------------|----------------------------|------------------------|
+| a ~ b         (homogeneous)   |        a ~ b               | (a :: *) ~  (b :: *)   |
+| a ~~ b,       homogeneously   |        a ~ b               | (a :: *) ~  (b :: *)   |
+| a ~~ b,       heterogeneously |        a ~~ c              | (a :: *) ~~ (c :: k)   |
+| a ~# b,       homogeneously   |        a ~ b               | (a :: *) ~  (b :: *)   |
+| a ~# b,       heterogeneously |        a ~~ c              | (a :: *) ~~ (c :: k)   |
+| Coercible a b (homogeneous)   |        Coercible a b       | Coercible * a b        |
+| a ~R# b,      homogeneously   |        Coercible a b       | Coercible * a b        |
+| a ~R# b,      heterogeneously |        a ~R# b             | (a :: *) ~R# (c :: k)  |
+|-------------------------------|----------------------------|------------------------|
+|         Predicate             | -fprint-equality-relations |      Both flags        |
+|-------------------------------|----------------------------|------------------------|
+| a ~ b         (homogeneous)   |        a ~  b              | (a :: *) ~  (b :: *)   |
+| a ~~ b,       homogeneously   |        a ~~ b              | (a :: *) ~~ (b :: *)   |
+| a ~~ b,       heterogeneously |        a ~~ c              | (a :: *) ~~ (c :: k)   |
+| a ~# b,       homogeneously   |        a ~# b              | (a :: *) ~# (b :: *)   |
+| a ~# b,       heterogeneously |        a ~# c              | (a :: *) ~# (c :: k)   |
+| Coercible a b (homogeneous)   |        Coercible a b       | Coercible * a b        |
+| a ~R# b,      homogeneously   |        a ~R# b             | (a :: *) ~R# (b :: *)  |
+| a ~R# b,      heterogeneously |        a ~R# b             | (a :: *) ~R# (c :: k)  |
+---------------------------------------------------------------------------------------
+
+(* There is no heterogeneous, representational, lifted equality counterpart
+to (~~). There could be, but there seems to be no use for it.)
+
+This table adheres to the following rules:
+
+A. With -fprint-equality-relations, print the true equality relation.
+B. Without -fprint-equality-relations:
+     i. If the equality is representational and homogeneous, use Coercible.
+    ii. Otherwise, if the equality is representational, use ~R#.
+   iii. If the equality is nominal and homogeneous, use ~.
+    iv. Otherwise, if the equality is nominal, use ~~.
+C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator,
+   as above; or print the kind with Coercible.
+D. Without -fprint-explicit-kinds, don't print kinds.
+
+A hetero-kinded equality is used homogeneously when it is applied to two
+identical kinds. Unfortunately, determining this from an IfaceType isn't
+possible since we can't see through type synonyms. Consequently, we need to
+record whether this particular application is homogeneous in IfaceTyConSort
+for the purposes of pretty-printing.
 
 See Note [The equality types story] in TysPrim.
 -}
@@ -236,47 +294,51 @@ data IfaceTyConInfo   -- Used to guide pretty-printing
                    , ifaceTyConSort       :: IfaceTyConSort }
     deriving (Eq)
 
+data IfaceMCoercion
+  = IfaceMRefl
+  | IfaceMCo IfaceCoercion
+
 data IfaceCoercion
-  = IfaceReflCo       Role IfaceType
+  = IfaceReflCo       IfaceType
+  | IfaceGReflCo      Role IfaceType (IfaceMCoercion)
   | IfaceFunCo        Role IfaceCoercion IfaceCoercion
   | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]
   | IfaceAppCo        IfaceCoercion IfaceCoercion
-  | IfaceForAllCo     IfaceTvBndr IfaceCoercion IfaceCoercion
+  | IfaceForAllCo     IfaceBndr IfaceCoercion IfaceCoercion
   | IfaceCoVarCo      IfLclName
   | IfaceAxiomInstCo  IfExtName BranchIndex [IfaceCoercion]
+  | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]
+       -- There are only a fixed number of CoAxiomRules, so it suffices
+       -- to use an IfaceLclName to distinguish them.
+       -- See Note [Adding built-in type families] in TcTypeNats
   | IfaceUnivCo       IfaceUnivCoProv Role IfaceType IfaceType
   | IfaceSymCo        IfaceCoercion
   | IfaceTransCo      IfaceCoercion IfaceCoercion
   | IfaceNthCo        Int IfaceCoercion
   | IfaceLRCo         LeftOrRight IfaceCoercion
   | IfaceInstCo       IfaceCoercion IfaceCoercion
-  | IfaceCoherenceCo  IfaceCoercion IfaceCoercion
   | IfaceKindCo       IfaceCoercion
   | IfaceSubCo        IfaceCoercion
-  | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]
+  | IfaceFreeCoVar    CoVar    -- See Note [Free tyvars in IfaceType]
+  | IfaceHoleCo       CoVar    -- ^ See Note [Holes in IfaceCoercion]
 
 data IfaceUnivCoProv
   = IfaceUnsafeCoerceProv
   | IfacePhantomProv IfaceCoercion
   | IfaceProofIrrelProv IfaceCoercion
   | IfacePluginProv String
-  | IfaceHoleProv Unique
-    -- ^ See Note [Holes in IfaceUnivCoProv]
 
-{-
-Note [Holes in IfaceUnivCoProv]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking fails the typechecker will produce a HoleProv UnivCoProv to
-stand in place of the unproven assertion. While we generally don't want to let
-these unproven assertions leak into interface files, we still need to be able to
-pretty-print them as we use IfaceType's pretty-printer to render Types. For this
-reason IfaceUnivCoProv has a IfaceHoleProv constructor; however, we fails when
-asked to serialize to a IfaceHoleProv to ensure that they don't end up in an
-interface file. To avoid an import loop between IfaceType and TyCoRep we only
-keep the hole's Unique, since that is all we need to print.
--}
+{- Note [Holes in IfaceCoercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking fails the typechecker will produce a HoleCo to stand
+in place of the unproven assertion. While we generally don't want to
+let these unproven assertions leak into interface files, we still need
+to be able to pretty-print them as we use IfaceType's pretty-printer
+to render Types. For this reason IfaceCoercion has a IfaceHoleCo
+constructor; however, we fails when asked to serialize to a
+IfaceHoleCo to ensure that they don't end up in an interface file.
+
 
-{-
 %************************************************************************
 %*                                                                      *
                 Functions over IFaceTypes
@@ -288,18 +350,33 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool
 ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key
 
 isIfaceLiftedTypeKind :: IfaceKind -> Bool
-isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
+isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil)
   = isLiftedTypeKindTyConName (ifaceTyConName tc)
 isIfaceLiftedTypeKind (IfaceTyConApp tc
-                       (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
+                       (IA_Vis (IfaceTyConApp ptr_rep_lifted IA_Nil) IA_Nil))
   =  tc `ifaceTyConHasKey` tYPETyConKey
   && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
 isIfaceLiftedTypeKind _ = False
 
 splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
 -- Mainly for printing purposes
+--
+-- Here we split nested IfaceSigmaTy properly.
+--
+-- @
+-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b)
+-- @
+--
+-- If you called @splitIfaceSigmaTy@ on this type:
+--
+-- @
+-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b))
+-- @
 splitIfaceSigmaTy ty
-  = (bndrs, theta, tau)
+  = case (bndrs, theta) of
+      ([], []) -> (bndrs, theta, tau)
+      _        -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau
+                   in (bndrs ++ bndrs', theta ++ theta', tau')
   where
     (bndrs, rho)   = split_foralls ty
     (theta, tau)   = split_rho rho
@@ -319,22 +396,30 @@ suppressIfaceInvisibles dflags tys xs
     where
       suppress _       []      = []
       suppress []      a       = a
-      suppress (k:ks) a@(_:xs)
-        | isInvisibleTyConBinder k = suppress ks xs
-        | otherwise                = a
+      suppress (k:ks) (x:xs)
+        | isInvisibleTyConBinder k =     suppress ks xs
+        | otherwise                = x : suppress ks xs
 
 stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
 stripIfaceInvisVars dflags tyvars
   | gopt Opt_PrintExplicitKinds dflags = tyvars
   | otherwise = filterOut isInvisibleTyConBinder tyvars
 
--- | Extract a IfaceTvBndr from a IfaceTyConBinder
-ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
-ifTyConBinderTyVar = binderVar
+-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'.
+ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr
+ifForAllBndrVar = binderVar
+
+-- | Extract the variable name from an 'IfaceForAllBndr'.
+ifForAllBndrName :: IfaceForAllBndr -> IfLclName
+ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab)
 
--- | Extract the variable name from a IfaceTyConBinder
+-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'.
+ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr
+ifTyConBinderVar = binderVar
+
+-- | Extract the variable name from an 'IfaceTyConBinder'.
 ifTyConBinderName :: IfaceTyConBinder -> IfLclName
-ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
+ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb)
 
 ifTypeIsVarFree :: IfaceType -> Bool
 -- Returns True if the type definitely has no variables at all
@@ -343,7 +428,7 @@ ifTypeIsVarFree ty = go ty
   where
     go (IfaceTyVar {})         = False
     go (IfaceFreeTyVar {})     = False
-    go (IfaceAppTy fun arg)    = go fun && go arg
+    go (IfaceAppTy fun args)   = go fun && go_args args
     go (IfaceFunTy arg res)    = go arg && go res
     go (IfaceDFunTy arg res)   = go arg && go res
     go (IfaceForAllTy {})      = False
@@ -353,9 +438,9 @@ ifTypeIsVarFree ty = go ty
     go (IfaceCastTy {})        = False -- Safe
     go (IfaceCoercionTy {})    = False -- Safe
 
-    go_args ITC_Nil = True
-    go_args (ITC_Vis   arg args) = go arg && go_args args
-    go_args (ITC_Invis arg args) = go arg && go_args args
+    go_args IA_Nil = True
+    go_args (IA_Vis   arg args) = go arg && go_args args
+    go_args (IA_Invis arg args) = go arg && go_args args
 
 {- Note [Substitution on IfaceType]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -380,22 +465,28 @@ substIfaceType env ty
   where
     go (IfaceFreeTyVar tv)    = IfaceFreeTyVar tv
     go (IfaceTyVar tv)        = substIfaceTyVar env tv
-    go (IfaceAppTy  t1 t2)    = IfaceAppTy  (go t1) (go t2)
+    go (IfaceAppTy  t ts)     = IfaceAppTy  (go t) (substIfaceAppArgs env ts)
     go (IfaceFunTy  t1 t2)    = IfaceFunTy  (go t1) (go t2)
     go (IfaceDFunTy t1 t2)    = IfaceDFunTy (go t1) (go t2)
     go ty@(IfaceLitTy {})     = ty
-    go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
-    go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
+    go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys)
+    go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys)
     go (IfaceForAllTy {})     = pprPanic "substIfaceType" (ppr ty)
     go (IfaceCastTy ty co)    = IfaceCastTy (go ty) (go_co co)
     go (IfaceCoercionTy co)   = IfaceCoercionTy (go_co co)
 
-    go_co (IfaceReflCo r ty)     = IfaceReflCo r (go ty)
-    go_co (IfaceFunCo r c1 c2)   = IfaceFunCo r (go_co c1) (go_co c2)
+    go_mco IfaceMRefl    = IfaceMRefl
+    go_mco (IfaceMCo co) = IfaceMCo $ go_co co
+
+    go_co (IfaceReflCo ty)           = IfaceReflCo (go ty)
+    go_co (IfaceGReflCo r ty mco)    = IfaceGReflCo r (go ty) (go_mco mco)
+    go_co (IfaceFunCo r c1 c2)       = IfaceFunCo r (go_co c1) (go_co c2)
     go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
     go_co (IfaceAppCo c1 c2)         = IfaceAppCo (go_co c1) (go_co c2)
     go_co (IfaceForAllCo {})         = pprPanic "substIfaceCoercion" (ppr ty)
+    go_co (IfaceFreeCoVar cv)        = IfaceFreeCoVar cv
     go_co (IfaceCoVarCo cv)          = IfaceCoVarCo cv
+    go_co (IfaceHoleCo cv)           = IfaceHoleCo cv
     go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
     go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
     go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)
@@ -403,7 +494,6 @@ substIfaceType env ty
     go_co (IfaceNthCo n co)          = IfaceNthCo n (go_co co)
     go_co (IfaceLRCo lr co)          = IfaceLRCo lr (go_co co)
     go_co (IfaceInstCo c1 c2)        = IfaceInstCo (go_co c1) (go_co c2)
-    go_co (IfaceCoherenceCo c1 c2)   = IfaceCoherenceCo (go_co c1) (go_co c2)
     go_co (IfaceKindCo co)           = IfaceKindCo (go_co co)
     go_co (IfaceSubCo co)            = IfaceSubCo (go_co co)
     go_co (IfaceAxiomRuleCo n cos)   = IfaceAxiomRuleCo n (go_cos cos)
@@ -414,15 +504,14 @@ substIfaceType env ty
     go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)
     go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
     go_prov (IfacePluginProv str)    = IfacePluginProv str
-    go_prov (IfaceHoleProv h)        = IfaceHoleProv h
 
-substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
-substIfaceTcArgs env args
+substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
+substIfaceAppArgs env args
   = go args
   where
-    go ITC_Nil            = ITC_Nil
-    go (ITC_Vis ty tys)   = ITC_Vis   (substIfaceType env ty) (go tys)
-    go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
+    go IA_Nil            = IA_Nil
+    go (IA_Vis ty tys)   = IA_Vis   (substIfaceType env ty) (go tys)
+    go (IA_Invis ty tys) = IA_Invis (substIfaceType env ty) (go tys)
 
 substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
 substIfaceTyVar env tv
@@ -433,47 +522,96 @@ substIfaceTyVar env tv
 {-
 ************************************************************************
 *                                                                      *
-                Functions over IFaceTcArgs
+                Functions over IfaceAppArgs
 *                                                                      *
 ************************************************************************
 -}
 
-stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
+stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs
 stripInvisArgs dflags tys
   | gopt Opt_PrintExplicitKinds dflags = tys
   | otherwise = suppress_invis tys
     where
       suppress_invis c
         = case c of
-            ITC_Invis _ ts -> suppress_invis ts
-            _ -> c
-
-tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
-tcArgsIfaceTypes ITC_Nil = []
-tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
-tcArgsIfaceTypes (ITC_Vis   t ts) = t : tcArgsIfaceTypes ts
-
-ifaceVisTcArgsLength :: IfaceTcArgs -> Int
-ifaceVisTcArgsLength = go 0
+            IA_Nil        -> IA_Nil
+            IA_Invis _ ts -> suppress_invis ts
+            IA_Vis   t ts -> IA_Vis t $ suppress_invis ts
+              -- Keep recursing through the remainder of the arguments, as it's
+              -- possible that there are remaining invisible ones.
+              -- See the "In type declarations" section of Note [VarBndrs,
+              -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
+
+appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType]
+appArgsIfaceTypes IA_Nil = []
+appArgsIfaceTypes (IA_Invis t ts) = t : appArgsIfaceTypes ts
+appArgsIfaceTypes (IA_Vis   t ts) = t : appArgsIfaceTypes ts
+
+ifaceVisAppArgsLength :: IfaceAppArgs -> Int
+ifaceVisAppArgsLength = go 0
   where
-    go !n ITC_Nil            = n
-    go n  (ITC_Vis _ rest)   = go (n+1) rest
-    go n  (ITC_Invis _ rest) = go n rest
+    go !n IA_Nil            = n
+    go n  (IA_Vis _ rest)   = go (n+1) rest
+    go n  (IA_Invis _ rest) = go n rest
 
 {-
 Note [Suppressing invisible arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use the IfaceTcArgs to specify which of the arguments to a type
-constructor should be displayed when pretty-printing, under
-the control of -fprint-explicit-kinds.
+We use the IfaceAppArgs data type to specify which of the arguments to a type
+should be displayed when pretty-printing, under the control of
+-fprint-explicit-kinds.
 See also Type.filterOutInvisibleTypes.
 For example, given
+
     T :: forall k. (k->*) -> k -> *    -- Ordinary kind polymorphism
     'Just :: forall k. k -> 'Maybe k   -- Promoted
+
 we want
-  T * Tree Int    prints as    T Tree Int
-  'Just *         prints as    Just *
 
+    T * Tree Int    prints as    T Tree Int
+    'Just *         prints as    Just *
+
+For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit,
+since the corresponding Core constructor:
+
+    data Type
+      = ...
+      | TyConApp TyCon [Type]
+
+Already puts all of its arguments into a list. So when converting a Type to an
+IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon
+(which is cached) to guide the process of converting the argument Types into an
+IfaceAppArgs list.
+
+We also want this behavior for IfaceAppTy, since given:
+
+    data Proxy (a :: k)
+    f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True)
+
+We want to print the return type as `Proxy (t True)` without the use of
+-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the
+tycon case, because the corresponding Core constructor for IfaceAppTy:
+
+    data Type
+      = ...
+      | AppTy Type Type
+
+Only stores one argument at a time. Therefore, when converting an AppTy to an
+IfaceAppTy (in toIfaceTypeX in ToIface), we:
+
+1. Flatten the chain of AppTys down as much as possible
+2. Use typeKind to determine the function Type's kind
+3. Use this kind to guide the process of converting the argument Types into an
+   IfaceAppArgs list.
+
+By flattening the arguments like this, we obtain two benefits:
+
+(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as
+    we do IfaceTyApp arguments, which means that we only need to implement the
+    logic to filter out invisible arguments once.
+(b) Unlike for tycons, finding the kind of a type in general (through typeKind)
+    is not a constant-time operation, so by flattening the arguments first, we
+    decrease the number of times we have to call typeKind.
 
 ************************************************************************
 *                                                                      *
@@ -493,15 +631,15 @@ if_print_coercions yes no
     then yes
     else no
 
-pprIfaceInfixApp :: TyPrec -> SDoc -> SDoc -> SDoc -> SDoc
+pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
 pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
-  = maybeParen ctxt_prec TyOpPrec $
+  = maybeParen ctxt_prec opPrec $
     sep [pp_ty1, pp_tc <+> pp_ty2]
 
-pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
+pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
 pprIfacePrefixApp ctxt_prec pp_fun pp_tys
   | null pp_tys = pp_fun
-  | otherwise   = maybeParen ctxt_prec TyConPrec $
+  | otherwise   = maybeParen ctxt_prec appPrec $
                   hang pp_fun 2 (sep pp_tys)
 
 -- ----------------------------- Printing binders ------------------------------------
@@ -529,9 +667,10 @@ pprIfaceTvBndr use_parens (tv, ki)
                  | otherwise  = id
 
 pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
-pprIfaceTyConBinders = sep . map go
+pprIfaceTyConBinders = sep . map (go . ifTyConBinderVar)
   where
-    go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)
+    go (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
+    go (IfaceTvBndr bndr) = pprIfaceTvBndr True bndr
 
 instance Binary IfaceBndr where
     put_ bh (IfaceIdBndr aa) = do
@@ -566,57 +705,58 @@ instance Outputable IfaceType where
   ppr ty = pprIfaceType ty
 
 pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
-pprIfaceType       = pprPrecIfaceType TopPrec
-pprParendIfaceType = pprPrecIfaceType TyConPrec
+pprIfaceType       = pprPrecIfaceType topPrec
+pprParendIfaceType = pprPrecIfaceType appPrec
 
-pprPrecIfaceType :: TyPrec -> IfaceType -> SDoc
+pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
+-- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe
+-- called from other places, besides `:type` and `:info`.
 pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
 
-ppr_ty :: TyPrec -> IfaceType -> SDoc
-ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reson for IfaceFreeTyVar!
+ppr_ty :: PprPrec -> IfaceType -> SDoc
+ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reason for IfaceFreeTyVar!
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [TcTyVars in IfaceType]
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
-ppr_ty _         (IfaceTupleTy i p tys) = pprTuple i p tys
+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
 ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n
         -- Function types
 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
-    maybeParen ctxt_prec FunPrec $
-    sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
+    maybeParen ctxt_prec funPrec $
+    sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
   where
     ppr_fun_tail (IfaceFunTy ty1 ty2)
-      = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
+      = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
     ppr_fun_tail other_ty
       = [arrow <+> pprIfaceType other_ty]
 
-ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
+ppr_ty ctxt_prec (IfaceAppTy t ts)
   = if_print_coercions
       ppr_app_ty
       ppr_app_ty_no_casts
   where
     ppr_app_ty =
-        maybeParen ctxt_prec TyConPrec
-        $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2
+        sdocWithDynFlags $ \dflags ->
+        pprIfacePrefixApp ctxt_prec
+                          (ppr_ty funPrec t)
+                          (map (ppr_ty appPrec) (tys_wo_kinds dflags))
+
+    tys_wo_kinds dflags = appArgsIfaceTypes $ stripInvisArgs dflags ts
 
     -- Strip any casts from the head of the application
     ppr_app_ty_no_casts =
-        case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
-          (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
-          _                          -> ppr_app_ty
-
-    split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
-    split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
-    split_app_tys head               args = (head, args)
+        case t of
+          IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts)
+          _                  -> ppr_app_ty
 
-    mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
+    mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType
     mk_app_tys (IfaceTyConApp tc tys1) tys2 =
         IfaceTyConApp tc (tys1 `mappend` tys2)
-    mk_app_tys t1                      tys2 =
-        foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
+    mk_app_tys t1 tys2 = IfaceAppTy t1 tys2
 
 ppr_ty ctxt_prec (IfaceCastTy ty co)
   = if_print_coercions
-      (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co))
+      (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
       (ppr_ty ctxt_prec ty)
 
 ppr_ty ctxt_prec (IfaceCoercionTy co)
@@ -624,8 +764,8 @@ ppr_ty ctxt_prec (IfaceCoercionTy co)
       (ppr_co ctxt_prec co)
       (text "<>")
 
-ppr_ty ctxt_prec ty
-  = maybeParen ctxt_prec FunPrec (pprIfaceSigmaType ShowForAllMust ty)
+ppr_ty ctxt_prec ty -- IfaceForAllTy
+  = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
 
 {-
 Note [Defaulting RuntimeRep variables]
@@ -649,7 +789,7 @@ overhead.
 
 For this reason it was decided that we would hide RuntimeRep variables for now
 (see #11549). We do this by defaulting all type variables of kind RuntimeRep to
-PtrLiftedRep. This is done in a pass right before pretty-printing
+LiftedRep. This is done in a pass right before pretty-printing
 (defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
 -}
 
@@ -668,30 +808,44 @@ PtrLiftedRep. This is done in a pass right before pretty-printing
 -- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
 -- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
 --
-defaultRuntimeRepVars :: IfaceType -> IfaceType
-defaultRuntimeRepVars = go emptyFsEnv
+defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
+defaultRuntimeRepVars sty = go emptyFsEnv
   where
     go :: FastStringEnv () -> IfaceType -> IfaceType
-    go subs (IfaceForAllTy bndr ty)
+    go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
       | isRuntimeRep var_kind
+      , isInvisibleArgFlag argf -- don't default *visible* quantification
+                                -- or we get the mess in #13963
       = let subs' = extendFsEnv subs var ()
         in go subs' ty
-      | otherwise
-      = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))
-        (go subs ty)
-      where
-        var :: IfLclName
-        (var, var_kind) = binderVar bndr
 
-    go subs (IfaceTyVar tv)
+    go subs (IfaceForAllTy bndr ty)
+      = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty)
+
+    go subs ty@(IfaceTyVar tv)
       | tv `elemFsEnv` subs
-      = IfaceTyConApp liftedRep ITC_Nil
+      = IfaceTyConApp liftedRep IA_Nil
+      | otherwise
+      = ty
+
+    go _ ty@(IfaceFreeTyVar tv)
+      | userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
+         -- don't require -fprint-explicit-runtime-reps for good debugging output
+      = IfaceTyConApp liftedRep IA_Nil
+      | otherwise
+      = ty
+
+    go subs (IfaceTyConApp tc tc_args)
+      = IfaceTyConApp tc (go_args subs tc_args)
 
-    go subs (IfaceFunTy kind ty)
-      = IfaceFunTy (go subs kind) (go subs ty)
+    go subs (IfaceTupleTy sort is_prom tc_args)
+      = IfaceTupleTy sort is_prom (go_args subs tc_args)
 
-    go subs (IfaceAppTy x y)
-      = IfaceAppTy (go subs x) (go subs y)
+    go subs (IfaceFunTy arg res)
+      = IfaceFunTy (go subs arg) (go subs res)
+
+    go subs (IfaceAppTy t ts)
+      = IfaceAppTy (go subs t) (go_args subs ts)
 
     go subs (IfaceDFunTy x y)
       = IfaceDFunTy (go subs x) (go subs y)
@@ -699,7 +853,19 @@ defaultRuntimeRepVars = go emptyFsEnv
     go subs (IfaceCastTy x co)
       = IfaceCastTy (go subs x) co
 
-    go _ other = other
+    go _ ty@(IfaceLitTy {}) = ty
+    go _ ty@(IfaceCoercionTy {}) = ty
+
+    go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr
+    go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf)
+      = Bndr (IfaceIdBndr (n, go subs t)) argf
+    go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)
+      = Bndr (IfaceTvBndr (n, go subs t)) argf
+
+    go_args :: FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs
+    go_args _ IA_Nil = IA_Nil
+    go_args subs (IA_Vis ty args)   = IA_Vis   (go subs ty) (go_args subs args)
+    go_args subs (IA_Invis ty args) = IA_Invis (go subs ty) (go_args subs args)
 
     liftedRep :: IfaceTyCon
     liftedRep =
@@ -715,28 +881,37 @@ eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
 eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
     if gopt Opt_PrintExplicitRuntimeReps dflags
       then f ty
-      else f (defaultRuntimeRepVars ty)
+      else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
 
-instance Outputable IfaceTcArgs where
-  ppr tca = pprIfaceTcArgs tca
+instance Outputable IfaceAppArgs where
+  ppr tca = pprIfaceAppArgs tca
 
-pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
-pprIfaceTcArgs  = ppr_tc_args TopPrec
-pprParendIfaceTcArgs = ppr_tc_args TyConPrec
+pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc
+pprIfaceAppArgs  = ppr_app_args topPrec
+pprParendIfaceAppArgs = ppr_app_args appPrec
 
-ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
-ppr_tc_args ctx_prec args
- = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
+ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc
+ppr_app_args ctx_prec args
+ = let ppr_rest    = ppr_app_args ctx_prec
+       pprTys t ts = ppr_ty ctx_prec t <+> ppr_rest ts
    in case args of
-        ITC_Nil        -> empty
-        ITC_Vis   t ts -> pprTys t ts
-        ITC_Invis t ts -> pprTys t ts
+        IA_Nil        -> empty
+        IA_Vis   t ts -> pprTys t ts
+        IA_Invis t ts -> sdocWithDynFlags $ \dflags ->
+                         if gopt Opt_PrintExplicitKinds dflags
+                            then pprTys t ts
+                            else ppr_rest ts
 
 -------------------
 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
 pprIfaceForAllPart tvs ctxt sdoc
   = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc
 
+-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@.
+pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
+pprIfaceForAllPartMust tvs ctxt sdoc
+  = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
+
 pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
 pprIfaceForAllCoPart tvs sdoc
   = sep [ pprIfaceForAllCo tvs, sdoc ]
@@ -753,7 +928,7 @@ ppr_iface_forall_part show_forall tvs ctxt sdoc
 -- | Render the "forall ... ." or "forall ... ->" bit of a type.
 pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
 pprIfaceForAll [] = empty
-pprIfaceForAll bndrs@(TvBndr _ vis : _)
+pprIfaceForAll bndrs@(Bndr _ vis : _)
   = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'
   where
     (bndrs', doc) = ppr_itv_bndrs bndrs vis
@@ -769,7 +944,7 @@ pprIfaceForAll bndrs@(TvBndr _ vis : _)
 ppr_itv_bndrs :: [IfaceForAllBndr]
              -> ArgFlag  -- ^ visibility of the first binder in the list
              -> ([IfaceForAllBndr], SDoc)
-ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1
+ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1
   | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
                          (bndrs', pprIfaceForAllBndr bndr <+> doc)
   | otherwise   = (all_bndrs, empty)
@@ -783,11 +958,13 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
 pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
 
 pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
-pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->
-                                           if gopt Opt_PrintExplicitForalls dflags
-                                           then braces $ pprIfaceTvBndr False tv
-                                           else pprIfaceTvBndr True tv
-pprIfaceForAllBndr (TvBndr tv _)        = pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) Inferred)
+  = sdocWithDynFlags $ \dflags ->
+                          if gopt Opt_PrintExplicitForalls dflags
+                          then braces $ pprIfaceTvBndr False tv
+                          else pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _)  = pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv
 
 pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
 pprIfaceForAllCoBndr (tv, kind_co)
@@ -802,102 +979,158 @@ data ShowForAllFlag = ShowForAllMust | ShowForAllWhen
 
 pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
 pprIfaceSigmaType show_forall ty
-  = ppr_iface_forall_part show_forall tvs theta (ppr tau)
+  = eliminateRuntimeRep ppr_fn ty
   where
-    (tvs, theta, tau) = splitIfaceSigmaTy ty
+    ppr_fn iface_ty =
+      let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty
+       in ppr_iface_forall_part show_forall tvs theta (ppr tau)
 
 pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
 pprUserIfaceForAll tvs
    = sdocWithDynFlags $ \dflags ->
-     ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
+     -- See Note [When to print foralls]
+     ppWhen (any tv_has_kind_var tvs
+             || any tv_is_required tvs
+             || gopt Opt_PrintExplicitForalls dflags) $
      pprIfaceForAll tvs
    where
-     tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)
+     tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _)
+       = not (ifTypeIsVarFree kind)
+     tv_has_kind_var _ = False
+
+     tv_is_required = isVisibleArgFlag . binderArgFlag
+
+{-
+Note [When to print foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We opt to explicitly pretty-print `forall`s if any of the following
+criteria are met:
+
+1. -fprint-explicit-foralls is on.
 
+2. A bound type variable has a polymorphic kind. E.g.,
+
+     forall k (a::k). Proxy a -> Proxy a
+
+   Since a's kind mentions a variable k, we print the foralls.
+
+3. A bound type variable is a visible argument (#14238).
+   Suppose we are printing the kind of:
+
+     T :: forall k -> k -> Type
+
+   The "forall k ->" notation means that this kind argument is required.
+   That is, it must be supplied at uses of T. E.g.,
+
+     f :: T (Type->Type)  Monad -> Int
+
+   So we print an explicit "T :: forall k -> k -> Type",
+   because omitting it and printing "T :: k -> Type" would be
+   utterly misleading.
+
+   See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+   in TyCoRep.
+
+N.B. Until now (Aug 2018) we didn't check anything for coercion variables.
+-}
 
 -------------------
 
+-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
+pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
+pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
+  = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
+      IsPromoted -> (space <>)
+      _ -> id
+pprSpaceIfPromotedTyCon _
+  = id
+
 -- See equivalent function in TyCoRep.hs
-pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
+pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 -- Given a type-level list (t1 ': t2), see if we can print
 -- it in list notation [t1, ...].
 -- Precondition: Opt_PrintExplicitKinds is off
 pprIfaceTyList ctxt_prec ty1 ty2
   = case gather ty2 of
       (arg_tys, Nothing)
-        -> char '\'' <> brackets (fsep (punctuate comma
-                        (map (ppr_ty TopPrec) (ty1:arg_tys))))
+        -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
+                        (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
       (arg_tys, Just tl)
-        -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
-           2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
+        -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
+           2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
   where
     gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
      -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
      --             = (tys, Just tl) means ty is of form t1:t2:...tn:tl
     gather (IfaceTyConApp tc tys)
       | tc `ifaceTyConHasKey` consDataConKey
-      , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
+      , (IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil))) <- tys
       , (args, tl) <- gather ty2
       = (ty1:args, tl)
       | tc `ifaceTyConHasKey` nilDataConKey
       = ([], Nothing)
     gather ty = ([], Just ty)
 
-pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
 pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
 
-pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
 pprTyTcApp ctxt_prec tc tys =
     sdocWithDynFlags $ \dflags ->
     getPprStyle $ \style ->
     pprTyTcApp' ctxt_prec tc tys dflags style
 
-pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs
+pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
             -> DynFlags -> PprStyle -> SDoc
 pprTyTcApp' ctxt_prec tc tys dflags style
   | ifaceTyConName tc `hasKey` ipClassKey
-  , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
-  = maybeParen ctxt_prec FunPrec
-    $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty
+  , IA_Vis (IfaceLitTy (IfaceStrTyLit n)) (IA_Vis ty IA_Nil) <- tys
+  = maybeParen ctxt_prec funPrec
+    $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
 
   | IfaceTupleTyCon arity sort <- ifaceTyConSort info
   , not (debugStyle style)
-  , arity == ifaceVisTcArgsLength tys
-  = pprTuple sort (ifaceTyConIsPromoted info) tys
+  , arity == ifaceVisAppArgsLength tys
+  = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
 
   | IfaceSumTyCon arity <- ifaceTyConSort info
   = pprSum arity (ifaceTyConIsPromoted info) tys
 
   | tc `ifaceTyConHasKey` consDataConKey
   , not (gopt Opt_PrintExplicitKinds dflags)
-  , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
+  , IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil)) <- tys
   = pprIfaceTyList ctxt_prec ty1 ty2
 
   | tc `ifaceTyConHasKey` tYPETyConKey
-  , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
+  , IA_Vis (IfaceTyConApp rep IA_Nil) IA_Nil <- tys
   , rep `ifaceTyConHasKey` liftedRepDataConKey
-  = kindStar
+  = kindType
 
   | otherwise
-  = sdocWithPprDebug $ \dbg ->
+  = getPprDebug $ \dbg ->
     if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
          -- Suppress detail unles you _really_ want to see
          -> text "(TypeError ...)"
 
-       | Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys)
+       | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
          -> doc
 
        | otherwise
          -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
   where
     info = ifaceTyConInfo tc
-    tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
+    tys_wo_kinds = appArgsIfaceTypes $ stripInvisArgs dflags tys
 
 -- | Pretty-print a type-level equality.
+-- Returns (Just doc) if the argument is a /saturated/ application
+-- of   eqTyCon          (~)
+--      eqPrimTyCon      (~#)
+--      eqReprPrimTyCon  (~R#)
+--      heqTyCon         (~~)
 --
 -- See Note [Equality predicates in IfaceType]
 -- and Note [The equality types story] in TysPrim
-ppr_equality :: TyPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
+ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
 ppr_equality ctxt_prec tc args
   | hetero_eq_tc
   , [k1, k2, t1, t2] <- args
@@ -910,94 +1143,119 @@ ppr_equality ctxt_prec tc args
   | otherwise
   = Nothing
   where
-    homogeneous = case ifaceTyConSort $ ifaceTyConInfo tc of
-                    IfaceEqualityTyCon hom -> hom
-                    _other -> pprPanic "ppr_equality: homogeneity" (ppr tc)
+    homogeneous = tc_name `hasKey` eqTyConKey -- (~)
+               || hetero_tc_used_homogeneously
+      where
+        hetero_tc_used_homogeneously
+          = case ifaceTyConSort $ ifaceTyConInfo tc of
+                          IfaceEqualityTyCon -> True
+                          _other             -> False
+             -- True <=> a heterogeneous equality whose arguments
+             --          are (in this case) of the same kind
+
     tc_name = ifaceTyConName tc
     pp = ppr_ty
     hom_eq_tc = tc_name `hasKey` eqTyConKey            -- (~)
     hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey     -- (~#)
                 || tc_name `hasKey` eqReprPrimTyConKey -- (~R#)
                 || tc_name `hasKey` heqTyConKey        -- (~~)
+    nominal_eq_tc = tc_name `hasKey` heqTyConKey       -- (~~)
+                 || tc_name `hasKey` eqPrimTyConKey    -- (~#)
     print_equality args =
         sdocWithDynFlags $ \dflags ->
         getPprStyle      $ \style  ->
         print_equality' args style dflags
 
     print_equality' (ki1, ki2, ty1, ty2) style dflags
-      | print_eqs
+      | -- If -fprint-equality-relations is on, just print the original TyCon
+        print_eqs
       = ppr_infix_eq (ppr tc)
 
-      | hetero_eq_tc
-      , print_kinds || not homogeneous
-      = ppr_infix_eq (text "~~")
+      | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2)
+        --                 or unlifted equality      (ty1 ~# ty2)
+        nominal_eq_tc, homogeneous
+      = ppr_infix_eq (text "~")
+
+      | -- Heterogeneous use of unlifted equality (ty1 ~# ty2)
+        not homogeneous
+      = ppr_infix_eq (ppr heqTyCon)
 
+      | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2)
+        tc_name `hasKey` eqReprPrimTyConKey, homogeneous
+      = let ki | print_kinds = [pp appPrec ki1]
+               | otherwise   = []
+        in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon)
+                            (ki ++ [pp appPrec ty1, pp appPrec ty2])
+
+        -- The other cases work as you'd expect
       | otherwise
-      = if tc_name `hasKey` eqReprPrimTyConKey
-        then pprIfacePrefixApp ctxt_prec (text "Coercible")
-                               [pp TyConPrec ty1, pp TyConPrec ty2]
-        else pprIfaceInfixApp ctxt_prec (char '~')
-                 (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+      = ppr_infix_eq (ppr tc)
       where
-        ppr_infix_eq eq_op
-           = pprIfaceInfixApp ctxt_prec eq_op
-                 (parens (pp TopPrec ty1 <+> dcolon <+> pp TyOpPrec ki1))
-                 (parens (pp TopPrec ty2 <+> dcolon <+> pp TyOpPrec ki2))
+        ppr_infix_eq :: SDoc -> SDoc
+        ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op
+                               (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2)
+          where
+            pp_ty_ki ty ki
+              | print_kinds
+              = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki)
+              | otherwise
+              = pp opPrec ty
 
         print_kinds = gopt Opt_PrintExplicitKinds dflags
         print_eqs   = gopt Opt_PrintEqualityRelations dflags ||
                       dumpStyle style || debugStyle style
 
 
-pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
+pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
 
-ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
+ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
 ppr_iface_tc_app pp _ tc [ty]
-  | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
-  | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
+  | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
 
 ppr_iface_tc_app pp ctxt_prec tc tys
-  |  tc `ifaceTyConHasKey` starKindTyConKey
-  || tc `ifaceTyConHasKey` liftedTypeKindTyConKey
-  || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
-  = kindStar   -- Handle unicode; do not wrap * in parens
+  | tc `ifaceTyConHasKey` liftedTypeKindTyConKey
+  = kindType
 
   | not (isSymOcc (nameOccName (ifaceTyConName tc)))
-  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
+  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
 
   | [ty1,ty2] <- tys  -- Infix, two arguments;
                       -- we know nothing of precedence though
   = pprIfaceInfixApp ctxt_prec (ppr tc)
-                     (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+                     (pp opPrec ty1) (pp opPrec ty2)
 
   | otherwise
-  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
+  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
 
-pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
+pprSum :: Arity -> IsPromoted -> IfaceAppArgs -> SDoc
 pprSum _arity is_promoted args
   =   -- drop the RuntimeRep vars.
       -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-    let tys   = tcArgsIfaceTypes args
+    let tys   = appArgsIfaceTypes args
         args' = drop (length tys `div` 2) tys
     in pprPromotionQuoteI is_promoted
-       <> sumParens (pprWithBars (ppr_ty TopPrec) args')
+       <> sumParens (pprWithBars (ppr_ty topPrec) args')
 
-pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
-pprTuple ConstraintTuple IsNotPromoted ITC_Nil
-  = text "() :: Constraint"
+pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceAppArgs -> SDoc
+pprTuple ctxt_prec ConstraintTuple IsNotPromoted IA_Nil
+  = maybeParen ctxt_prec appPrec $
+    text "() :: Constraint"
 
 -- All promoted constructors have kind arguments
-pprTuple sort IsPromoted args
-  = let tys = tcArgsIfaceTypes args
+pprTuple _ sort IsPromoted args
+  = let tys = appArgsIfaceTypes args
         args' = drop (length tys `div` 2) tys
+        spaceIfPromoted = case args' of
+          arg0:_ -> pprSpaceIfPromotedTyCon arg0
+          _ -> id
     in pprPromotionQuoteI IsPromoted <>
-       tupleParens sort (pprWithCommas pprIfaceType args')
+       tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
 
-pprTuple sort promoted args
+pprTuple _ sort promoted args
   =   -- drop the RuntimeRep vars.
       -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-    let tys   = tcArgsIfaceTypes args
+    let tys   = appArgsIfaceTypes args
         args' = case sort of
                   UnboxedTuple -> drop (length tys `div` 2) tys
                   _            -> tys
@@ -1010,76 +1268,84 @@ pprIfaceTyLit (IfaceNumTyLit n) = integer n
 pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
 
 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
-pprIfaceCoercion = ppr_co TopPrec
-pprParendIfaceCoercion = ppr_co TyConPrec
-
-ppr_co :: TyPrec -> IfaceCoercion -> SDoc
-ppr_co _         (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
+pprIfaceCoercion = ppr_co topPrec
+pprParendIfaceCoercion = ppr_co appPrec
+
+ppr_co :: PprPrec -> IfaceCoercion -> SDoc
+ppr_co _         (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal
+ppr_co _         (IfaceGReflCo r ty IfaceMRefl)
+  = angleBrackets (ppr ty) <> ppr_role r
+ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co))
+  = ppr_special_co ctxt_prec
+    (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co]
 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
-  = maybeParen ctxt_prec FunPrec $
-    sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
+  = maybeParen ctxt_prec funPrec $
+    sep (ppr_co funPrec co1 : ppr_fun_tail co2)
   where
     ppr_fun_tail (IfaceFunCo r co1 co2)
-      = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
+      = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
     ppr_fun_tail other_co
       = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
 
 ppr_co _         (IfaceTyConAppCo r tc cos)
-  = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
+  = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
 ppr_co ctxt_prec (IfaceAppCo co1 co2)
-  = maybeParen ctxt_prec TyConPrec $
-    ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
+  = maybeParen ctxt_prec appPrec $
+    ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
 ppr_co ctxt_prec co@(IfaceForAllCo {})
-  = maybeParen ctxt_prec FunPrec $
+  = maybeParen ctxt_prec funPrec $
     pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
   where
     (tvs, inner_co) = split_co co
 
-    split_co (IfaceForAllCo (name, _) kind_co co')
+    split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co')
+      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
+    split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co')
       = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
     split_co co' = ([], co')
 
-ppr_co _         (IfaceCoVarCo covar)       = ppr covar
+-- Why these three? See Note [TcTyVars in IfaceType]
+ppr_co _ (IfaceFreeCoVar covar) = ppr covar
+ppr_co _ (IfaceCoVarCo covar)   = ppr covar
+ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar)
 
 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
-  = maybeParen ctxt_prec TyConPrec $
+  = maybeParen ctxt_prec appPrec $
     text "UnsafeCo" <+> ppr r <+>
     pprParendIfaceType ty1 <+> pprParendIfaceType ty2
 
-ppr_co _ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _)
- = braces $ ppr u
-
-ppr_co _         (IfaceUnivCo _ _ ty1 ty2)
-  = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )
+ppr_co _ (IfaceUnivCo prov role ty1 ty2)
+  = text "Univ" <> (parens $
+      sep [ ppr role <+> pprIfaceUnivCoProv prov
+          , dcolon <+>  ppr ty1 <> comma <+> ppr ty2 ])
 
 ppr_co ctxt_prec (IfaceInstCo co ty)
-  = maybeParen ctxt_prec TyConPrec $
+  = maybeParen ctxt_prec appPrec $
     text "Inst" <+> pprParendIfaceCoercion co
                         <+> pprParendIfaceCoercion ty
 
 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
-  = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
+  = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
 
 ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
   = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
 ppr_co ctxt_prec (IfaceSymCo co)
   = ppr_special_co ctxt_prec (text "Sym") [co]
 ppr_co ctxt_prec (IfaceTransCo co1 co2)
-  = ppr_special_co ctxt_prec  (text "Trans") [co1,co2]
+  = maybeParen ctxt_prec opPrec $
+    ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
 ppr_co ctxt_prec (IfaceNthCo d co)
   = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
 ppr_co ctxt_prec (IfaceLRCo lr co)
   = ppr_special_co ctxt_prec (ppr lr) [co]
 ppr_co ctxt_prec (IfaceSubCo co)
   = ppr_special_co ctxt_prec (text "Sub") [co]
-ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
-  = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
 ppr_co ctxt_prec (IfaceKindCo co)
   = ppr_special_co ctxt_prec (text "Kind") [co]
 
-ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
+ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
 ppr_special_co ctxt_prec doc cos
-  = maybeParen ctxt_prec TyConPrec
+  = maybeParen ctxt_prec appPrec
                (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
 
 ppr_role :: Role -> SDoc
@@ -1089,6 +1355,17 @@ ppr_role r = underscore <> pp_role
                     Representational -> char 'R'
                     Phantom          -> char 'P'
 
+------------------
+pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
+pprIfaceUnivCoProv IfaceUnsafeCoerceProv
+  = text "unsafe"
+pprIfaceUnivCoProv (IfacePhantomProv co)
+  = text "phantom" <+> pprParendIfaceCoercion co
+pprIfaceUnivCoProv (IfaceProofIrrelProv co)
+  = text "irrel" <+> pprParendIfaceCoercion co
+pprIfaceUnivCoProv (IfacePluginProv s)
+  = text "plugin" <+> doubleQuotes (text s)
+
 -------------------
 instance Outputable IfaceTyCon where
   ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
@@ -1126,9 +1403,7 @@ instance Binary IfaceTyConSort where
    put_ bh IfaceNormalTyCon             = putByte bh 0
    put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
    put_ bh (IfaceSumTyCon arity)        = putByte bh 2 >> put_ bh arity
-   put_ bh (IfaceEqualityTyCon hom)
-     | hom                              = putByte bh 3
-     | otherwise                        = putByte bh 4
+   put_ bh IfaceEqualityTyCon           = putByte bh 3
 
    get bh = do
        n <- getByte bh
@@ -1136,9 +1411,7 @@ instance Binary IfaceTyConSort where
          0 -> return IfaceNormalTyCon
          1 -> IfaceTupleTyCon <$> get bh <*> get bh
          2 -> IfaceSumTyCon <$> get bh
-         3 -> return $ IfaceEqualityTyCon True
-         4 -> return $ IfaceEqualityTyCon False
-         _ -> fail "Binary(IfaceTyConSort): fail"
+         _ -> return IfaceEqualityTyCon
 
 instance Binary IfaceTyConInfo where
    put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
@@ -1161,12 +1434,12 @@ instance Binary IfaceTyLit where
                  ; return (IfaceStrTyLit n) }
          _ -> panic ("get IfaceTyLit " ++ show tag)
 
-instance Binary IfaceTcArgs where
+instance Binary IfaceAppArgs where
   put_ bh tk =
     case tk of
-      ITC_Vis   t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
-      ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
-      ITC_Nil        -> putByte bh 2
+      IA_Vis   t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
+      IA_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
+      IA_Nil        -> putByte bh 2
 
   get bh =
     do c <- getByte bh
@@ -1174,13 +1447,13 @@ instance Binary IfaceTcArgs where
          0 -> do
            t  <- get bh
            ts <- get bh
-           return $! ITC_Vis t ts
+           return $! IA_Vis t ts
          1 -> do
            t  <- get bh
            ts <- get bh
-           return $! ITC_Invis t ts
-         2 -> return ITC_Nil
-         _ -> panic ("get IfaceTcArgs " ++ show c)
+           return $! IA_Invis t ts
+         2 -> return IA_Nil
+         _ -> panic ("get IfaceAppArgs " ++ show c)
 
 -------------------
 
@@ -1188,7 +1461,7 @@ instance Binary IfaceTcArgs where
 --
 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
 -- omit parentheses. However, we must take care to set the precedence correctly
--- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see
+-- to opPrec, since something like @a :~: b@ must be parenthesized (see
 -- #9658).
 --
 -- When printing a larger context we use 'fsep' instead of 'sep' so that
@@ -1217,16 +1490,16 @@ instance Binary IfaceTcArgs where
 
 -- | Prints "(C a, D b) =>", including the arrow.
 -- Used when we want to print a context in a type, so we
--- use FunPrec to decide whether to parenthesise a singleton
+-- use 'funPrec' to decide whether to parenthesise a singleton
 -- predicate; e.g.   Num a => a -> a
 pprIfaceContextArr :: [IfacePredType] -> SDoc
 pprIfaceContextArr []     = empty
-pprIfaceContextArr [pred] = ppr_ty FunPrec pred <+> darrow
+pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
 pprIfaceContextArr preds  = ppr_parend_preds preds <+> darrow
 
 -- | Prints a context or @()@ if empty
 -- You give it the context precedence
-pprIfaceContext :: TyPrec -> [IfacePredType] -> SDoc
+pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
 pprIfaceContext _    []     = text "()"
 pprIfaceContext prec [pred] = ppr_ty prec pred
 pprIfaceContext _    preds  = ppr_parend_preds preds
@@ -1297,64 +1570,79 @@ instance Binary IfaceType where
               _  -> do n <- get bh
                        return (IfaceLitTy n)
 
+instance Binary IfaceMCoercion where
+  put_ bh IfaceMRefl = do
+          putByte bh 1
+  put_ bh (IfaceMCo co) = do
+          putByte bh 2
+          put_ bh co
+
+  get bh = do
+    tag <- getByte bh
+    case tag of
+         1 -> return IfaceMRefl
+         2 -> do a <- get bh
+                 return $ IfaceMCo a
+         _ -> panic ("get IfaceMCoercion " ++ show tag)
+
 instance Binary IfaceCoercion where
-  put_ bh (IfaceReflCo a b) = do
+  put_ bh (IfaceReflCo a) = do
           putByte bh 1
           put_ bh a
+  put_ bh (IfaceGReflCo a b c) = do
+          putByte bh 2
+          put_ bh a
           put_ bh b
+          put_ bh c
   put_ bh (IfaceFunCo a b c) = do
-          putByte bh 2
+          putByte bh 3
           put_ bh a
           put_ bh b
           put_ bh c
   put_ bh (IfaceTyConAppCo a b c) = do
-          putByte bh 3
+          putByte bh 4
           put_ bh a
           put_ bh b
           put_ bh c
   put_ bh (IfaceAppCo a b) = do
-          putByte bh 4
+          putByte bh 5
           put_ bh a
           put_ bh b
   put_ bh (IfaceForAllCo a b c) = do
-          putByte bh 5
+          putByte bh 6
           put_ bh a
           put_ bh b
           put_ bh c
   put_ bh (IfaceCoVarCo a) = do
-          putByte bh 6
+          putByte bh 7
           put_ bh a
   put_ bh (IfaceAxiomInstCo a b c) = do
-          putByte bh 7
+          putByte bh 8
           put_ bh a
           put_ bh b
           put_ bh c
   put_ bh (IfaceUnivCo a b c d) = do
-          putByte bh 8
+          putByte bh 9
           put_ bh a
           put_ bh b
           put_ bh c
           put_ bh d
   put_ bh (IfaceSymCo a) = do
-          putByte bh 9
-          put_ bh a
-  put_ bh (IfaceTransCo a b) = do
           putByte bh 10
           put_ bh a
-          put_ bh b
-  put_ bh (IfaceNthCo a b) = do
+  put_ bh (IfaceTransCo a b) = do
           putByte bh 11
           put_ bh a
           put_ bh b
-  put_ bh (IfaceLRCo a b) = do
+  put_ bh (IfaceNthCo a b) = do
           putByte bh 12
           put_ bh a
           put_ bh b
-  put_ bh (IfaceInstCo a b) = do
+  put_ bh (IfaceLRCo a b) = do
           putByte bh 13
           put_ bh a
           put_ bh b
-  put_ bh (IfaceCoherenceCo a b) = do
+  put_ bh (IfaceInstCo a b) = do
           putByte bh 14
           put_ bh a
           put_ bh b
@@ -1368,56 +1656,61 @@ instance Binary IfaceCoercion where
           putByte bh 17
           put_ bh a
           put_ bh b
+  put_ _ (IfaceFreeCoVar cv)
+       = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
+  put_ _  (IfaceHoleCo cv)
+       = pprPanic "Can't serialise IfaceHoleCo" (ppr cv)
+          -- See Note [Holes in IfaceUnivCoProv]
 
   get bh = do
       tag <- getByte bh
       case tag of
            1 -> do a <- get bh
-                   b <- get bh
-                   return $ IfaceReflCo a b
+                   return $ IfaceReflCo a
            2 -> do a <- get bh
                    b <- get bh
                    c <- get bh
-                   return $ IfaceFunCo a b c
+                   return $ IfaceGReflCo a b c
            3 -> do a <- get bh
                    b <- get bh
                    c <- get bh
-                   return $ IfaceTyConAppCo a b c
+                   return $ IfaceFunCo a b c
            4 -> do a <- get bh
                    b <- get bh
-                   return $ IfaceAppCo a b
+                   c <- get bh
+                   return $ IfaceTyConAppCo a b c
            5 -> do a <- get bh
                    b <- get bh
+                   return $ IfaceAppCo a b
+           6 -> do a <- get bh
+                   b <- get bh
                    c <- get bh
                    return $ IfaceForAllCo a b c
-           6 -> do a <- get bh
-                   return $ IfaceCoVarCo a
            7 -> do a <- get bh
+                   return $ IfaceCoVarCo a
+           8 -> do a <- get bh
                    b <- get bh
                    c <- get bh
                    return $ IfaceAxiomInstCo a b c
-           8 -> do a <- get bh
+           9 -> do a <- get bh
                    b <- get bh
                    c <- get bh
                    d <- get bh
                    return $ IfaceUnivCo a b c d
-           9 -> do a <- get bh
-                   return $ IfaceSymCo a
            10-> do a <- get bh
-                   b <- get bh
-                   return $ IfaceTransCo a b
+                   return $ IfaceSymCo a
            11-> do a <- get bh
                    b <- get bh
-                   return $ IfaceNthCo a b
+                   return $ IfaceTransCo a b
            12-> do a <- get bh
                    b <- get bh
-                   return $ IfaceLRCo a b
+                   return $ IfaceNthCo a b
            13-> do a <- get bh
                    b <- get bh
-                   return $ IfaceInstCo a b
+                   return $ IfaceLRCo a b
            14-> do a <- get bh
                    b <- get bh
-                   return $ IfaceCoherenceCo a b
+                   return $ IfaceInstCo a b
            15-> do a <- get bh
                    return $ IfaceKindCo a
            16-> do a <- get bh
@@ -1438,9 +1731,6 @@ instance Binary IfaceUnivCoProv where
   put_ bh (IfacePluginProv a) = do
           putByte bh 4
           put_ bh a
-  put_ _  (IfaceHoleProv _) =
-          pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty
-  -- See Note [Holes in IfaceUnivCoProv]
 
   get bh = do
       tag <- getByte bh
diff --git a/compiler/iface/IfaceType.hs-boot b/compiler/iface/IfaceType.hs-boot
index 7488aa587c..44f1f3cfc2 100644
--- a/compiler/iface/IfaceType.hs-boot
+++ b/compiler/iface/IfaceType.hs-boot
@@ -1,18 +1,15 @@
 -- Used only by ToIface.hs-boot
 
 module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr
-                , IfaceCoercion, IfaceTyLit, IfaceTcArgs ) where
+                , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where
 
-import Var (TyVarBndr, ArgFlag)
-import FastString (FastString)
+import Var (VarBndr, ArgFlag)
 
-data IfaceTcArgs
-type IfLclName = FastString
-type IfaceKind = IfaceType
+data IfaceAppArgs
 
 data IfaceType
 data IfaceTyCon
 data IfaceTyLit
 data IfaceCoercion
-type IfaceTvBndr      = (IfLclName, IfaceKind)
-type IfaceForAllBndr  = TyVarBndr IfaceTvBndr ArgFlag
+data IfaceBndr
+type IfaceForAllBndr  = VarBndr IfaceBndr ArgFlag
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index b1a3ef1e6f..34ba1cbb7a 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -6,7 +6,7 @@
 Loading interface files
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module LoadIface (
         -- Importing one thing
@@ -16,7 +16,7 @@ module LoadIface (
         -- RnM/TcM functions
         loadModuleInterface, loadModuleInterfaces,
         loadSrcInterface, loadSrcInterface_maybe,
-        loadInterfaceForName, loadInterfaceForModule,
+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
 
         -- IfM functions
         loadInterface,
@@ -25,6 +25,7 @@ module LoadIface (
         loadDecls,      -- Should move to TcIface and be renamed
         initExternalPackageState,
         moduleFreeHolesPrecise,
+        needWiredInHomeIface, loadWiredInHomeIface,
 
         pprModIfaceSimple,
         ifaceStats, pprModIface, showIface
@@ -32,8 +33,10 @@ module LoadIface (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
-                                 tcIfaceFamInst, tcIfaceVectInfo,
+                                 tcIfaceFamInst,
                                  tcIfaceAnnotations, tcIfaceCompleteSigs )
 
 import DynFlags
@@ -74,6 +77,7 @@ import Hooks
 import FieldLabel
 import RnModIface
 import UniqDSet
+import Plugins
 
 import Control.Monad
 import Control.Exception
@@ -144,7 +148,7 @@ importDecl name
         { eps <- getEps
         ; case lookupTypeEnv (eps_PTE eps) name of
             Just thing -> return $ Succeeded thing
-            Nothing    -> let doc = ifPprDebug (found_things_msg eps $$ empty)
+            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)
                                     $$ not_found_msg
                           in return $ Failed doc
     }}}
@@ -309,6 +313,15 @@ loadInterfaceForName doc name
       ; ASSERT2( isExternalName name, ppr name )
         initIfaceTcRn $ loadSysInterface doc (nameModule name) }
 
+-- | Only loads the interface for external non-local names.
+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
+loadInterfaceForNameMaybe doc name
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
+         then return Nothing
+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
+       }
+
 -- | Loads the interface for a given Module.
 loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
 loadInterfaceForModule doc m
@@ -440,6 +453,8 @@ loadInterface doc_str mod from
         in
         initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
 
+        dontLeakTheHPT $ do
+
         --      Load the new ModIface into the External Package State
         -- Even home-package interfaces loaded by loadInterface
         --      (which only happens in OneShot mode; in Batch/Interactive
@@ -448,7 +463,7 @@ loadInterface doc_str mod from
         --
         -- The main thing is to add the ModIface to the PIT, but
         -- we also take the
-        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo
+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,
         -- out of the ModIface and put them into the big EPS pools
 
         -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
@@ -462,7 +477,6 @@ loadInterface doc_str mod from
         ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
         ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
         ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
-        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)
         ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
 
         ; let { final_iface = iface {
@@ -490,8 +504,6 @@ loadInterface doc_str mod from
                                                        new_eps_insts,
                   eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
                                                           new_eps_fam_insts,
-                  eps_vect_info    = plusVectInfo (eps_vect_info eps)
-                                                  new_eps_vect_info,
                   eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
                                                       new_eps_anns,
                   eps_mod_fam_inst_env
@@ -508,9 +520,59 @@ loadInterface doc_str mod from
                                                    (length new_eps_insts)
                                                    (length new_eps_rules) }
 
-        ; return (Succeeded final_iface)
+        ; -- invoke plugins
+          res <- withPlugins dflags interfaceLoadAction final_iface
+        ; return (Succeeded res)
     }}}}
 
+
+
+-- Note [HPT space leak] (#15111)
+--
+-- In IfL, we defer some work until it is demanded using forkM, such
+-- as building TyThings from IfaceDecls. These thunks are stored in
+-- the ExternalPackageState, and they might never be poked.  If we're
+-- not careful, these thunks will capture the state of the loaded
+-- program when we read an interface file, and retain all that data
+-- for ever.
+--
+-- Therefore, when loading a package interface file , we use a "clean"
+-- version of the HscEnv with all the data about the currently loaded
+-- program stripped out. Most of the fields can be panics because
+-- we'll never read them, but hsc_HPT needs to be empty because this
+-- interface will cause other interfaces to be loaded recursively, and
+-- when looking up those interfaces we use the HPT in loadInterface.
+-- We know that none of the interfaces below here can refer to
+-- home-package modules however, so it's safe for the HPT to be empty.
+--
+dontLeakTheHPT :: IfL a -> IfL a
+dontLeakTheHPT thing_inside = do
+  let
+    cleanTopEnv HscEnv{..} =
+       let
+         -- wrinkle: when we're typechecking in --backpack mode, the
+         -- instantiation of a signature might reside in the HPT, so
+         -- this case breaks the assumption that EPS interfaces only
+         -- refer to other EPS interfaces. We can detect when we're in
+         -- typechecking-only mode by using hscTarget==HscNothing, and
+         -- in that case we don't empty the HPT.  (admittedly this is
+         -- a bit of a hack, better suggestions welcome). A number of
+         -- tests in testsuite/tests/backpack break without this
+         -- tweak.
+         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT
+              | otherwise = emptyHomePackageTable
+       in
+       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"
+              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"
+              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
+              ,  hsc_HPT          = hpt
+              , .. }
+
+  updTopEnv cleanTopEnv $ do
+  !_ <- getTopEnv        -- force the updTopEnv
+  thing_inside
+
+
 -- | Returns @True@ if a 'ModIface' comes from an external package.
 -- In this case, we should NOT load it into the EPS; the entities
 -- should instead come from the local merged signature interface.
@@ -926,7 +988,6 @@ initExternalPackageState
         -- Initialise the EPS rule pool with the built-in rules
       eps_mod_fam_inst_env
                            = emptyModuleEnv,
-      eps_vect_info        = noVectInfo,
       eps_complete_matches = emptyUFM,
       eps_ann_env          = emptyAnnEnv,
       eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
@@ -986,6 +1047,15 @@ ifaceStats eps
                 Printing interfaces
 *                                                                      *
 ************************************************************************
+
+Note [Name qualification with --show-iface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In order to disambiguate between identifiers from different modules, we qualify
+all names that don't originate in the current module. In order to keep visual
+noise as low as possible, we keep local names unqualified.
+
+For some background on this choice see trac #15269.
 -}
 
 -- | Read binary interface, and print it out
@@ -996,8 +1066,15 @@ showIface hsc_env filename = do
    iface <- initTcRnIf 's' hsc_env () () $
        readBinIface IgnoreHiWay TraceBinIFaceReading filename
    let dflags = hsc_dflags hsc_env
+       -- See Note [Name qualification with --show-iface]
+       qualifyImportedNames mod _
+           | mod == mi_module iface = NameUnqual
+           | otherwise              = NameNotInScope1
+       print_unqual = QueryQualify qualifyImportedNames
+                                   neverQualifyModules
+                                   neverQualifyPackages
    putLogMsg dflags NoReason SevDump noSrcSpan
-      (defaultDumpStyle dflags) (pprModIface iface)
+      (mkDumpStyle dflags print_unqual) (pprModIface iface)
 
 -- Show a ModIface but don't display details; suitable for ModIfaces stored in
 -- the EPT.
@@ -1018,6 +1095,9 @@ pprModIface iface
         , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
         , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
         , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))
+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))
+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))
         , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
         , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
         , nest 2 (text "where")
@@ -1031,11 +1111,13 @@ pprModIface iface
         , vcat (map ppr (mi_insts iface))
         , vcat (map ppr (mi_fam_insts iface))
         , vcat (map ppr (mi_rules iface))
-        , pprVectInfo (mi_vect_info iface)
         , ppr (mi_warns iface)
         , pprTrustInfo (mi_trust iface)
         , pprTrustPkg (mi_trust_pkg iface)
         , vcat (map ppr (mi_complete_sigs iface))
+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
         ]
   where
     pp_hsc_src HsBootFile = text "[boot]"
@@ -1071,7 +1153,8 @@ pprUsage usage@UsageHomeModule{}
         )
 pprUsage usage@UsageFile{}
   = hsep [text "addDependentFile",
-          doubleQuotes (text (usg_file_path usage))]
+          doubleQuotes (text (usg_file_path usage)),
+          ppr (usg_file_hash usage)]
 pprUsage usage@UsageMergedRequirement{}
   = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
 
@@ -1104,21 +1187,6 @@ pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
                   where
                     pprFix (occ,fix) = ppr fix <+> ppr occ
 
-pprVectInfo :: IfaceVectInfo -> SDoc
-pprVectInfo (IfaceVectInfo { ifaceVectInfoVar            = vars
-                           , ifaceVectInfoTyCon          = tycons
-                           , ifaceVectInfoTyConReuse     = tyconsReuse
-                           , ifaceVectInfoParallelVars   = parallelVars
-                           , ifaceVectInfoParallelTyCons = parallelTyCons
-                           }) =
-  vcat
-  [ text "vectorised variables:" <+> hsep (map ppr vars)
-  , text "vectorised tycons:" <+> hsep (map ppr tycons)
-  , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse)
-  , text "parallel variables:" <+> hsep (map ppr parallelVars)
-  , text "parallel tycons:" <+> hsep (map ppr parallelTyCons)
-  ]
-
 pprTrustInfo :: IfaceTrustInfo -> SDoc
 pprTrustInfo trust = text "trusted:" <+> ppr trust
 
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 78787c9827..4d2fa83f86 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -4,6 +4,7 @@
 -}
 
 {-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE MultiWayIf #-}
 
 -- | Module for constructing @ModIface@ values (interface files),
 -- writing them to disk and comparing two versions to see if
@@ -58,6 +59,8 @@ Basic idea:
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import IfaceSyn
 import BinFingerprint
 import LoadIface
@@ -83,7 +86,6 @@ import HscTypes
 import Finder
 import DynFlags
 import VarEnv
-import VarSet
 import Var
 import Name
 import Avail
@@ -106,6 +108,7 @@ import Fingerprint
 import Exception
 import UniqSet
 import Packages
+import ExtractDocs
 
 import Control.Monad
 import Data.Function
@@ -115,6 +118,11 @@ import Data.Ord
 import Data.IORef
 import System.Directory
 import System.FilePath
+import Plugins ( PluginRecompile(..), Plugin(..), LoadedPlugin(..))
+
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
 
 {-
 ************************************************************************
@@ -144,12 +152,17 @@ mkIface hsc_env maybe_old_fingerprint mod_details
                       mg_warns        = warns,
                       mg_hpc_info     = hpc_info,
                       mg_safe_haskell = safe_mode,
-                      mg_trust_pkg    = self_trust
+                      mg_trust_pkg    = self_trust,
+                      mg_doc_hdr      = doc_hdr,
+                      mg_decl_docs    = decl_docs,
+                      mg_arg_docs     = arg_docs
                     }
         = mkIface_ hsc_env maybe_old_fingerprint
                    this_mod hsc_src used_th deps rdr_env fix_env
                    warns hpc_info self_trust
-                   safe_mode usages mod_details
+                   safe_mode usages
+                   doc_hdr decl_docs arg_docs
+                   mod_details
 
 -- | make an interface from the results of typechecking only.  Useful
 -- for non-optimising compilation, or where we aren't generating any
@@ -174,7 +187,11 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
                     }
   = do
           let used_names = mkUsedNames tc_result
-          deps <- mkDependencies tc_result
+          let pluginModules =
+                map lpModule (plugins (hsc_dflags hsc_env))
+          deps <- mkDependencies
+                    (thisInstalledUnitId (hsc_dflags hsc_env))
+                    (map mi_module pluginModules) tc_result
           let hpc_info = emptyHpcInfo other_hpc_info
           used_th <- readIORef tc_splice_used
           dep_files <- (readIORef dependent_files)
@@ -185,12 +202,19 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
           -- but if you pass that in here, we'll decide it's the local
           -- module and does not need to be recorded as a dependency.
           -- See Note [Identity versus semantic module]
-          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged
+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
+
+          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
           mkIface_ hsc_env maybe_old_fingerprint
                    this_mod hsc_src
                    used_th deps rdr_env
                    fix_env warns hpc_info
-                   (imp_trust_own_pkg imports) safe_mode usages mod_details
+                   (imp_trust_own_pkg imports) safe_mode usages
+                   doc_hdr' doc_map arg_map
+                   mod_details
+
 
 
 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
@@ -199,16 +223,19 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
          -> Bool
          -> SafeHaskellMode
          -> [Usage]
+         -> Maybe HsDocString
+         -> DeclDocMap
+         -> ArgDocMap
          -> ModDetails
          -> IO (ModIface, Bool)
 mkIface_ hsc_env maybe_old_fingerprint
          this_mod hsc_src used_th deps rdr_env fix_env src_warns
          hpc_info pkg_trust_req safe_mode usages
+         doc_hdr decl_docs arg_docs
          ModDetails{  md_insts     = insts,
                       md_fam_insts = fam_insts,
                       md_rules     = rules,
                       md_anns      = anns,
-                      md_vect_info = vect_info,
                       md_types     = type_env,
                       md_exports   = exports,
                       md_complete_sigs = complete_sigs }
@@ -243,7 +270,6 @@ mkIface_ hsc_env maybe_old_fingerprint
         iface_rules = map coreRuleToIfaceRule rules
         iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
         iface_fam_insts = map famInstToIfaceFamInst fam_insts
-        iface_vect_info = flattenVectInfo vect_info
         trust_info  = setSafeMode safe_mode
         annotations = map mkIfaceAnnotation anns
         icomplete_sigs = map mkIfaceCompleteSig complete_sigs
@@ -266,8 +292,6 @@ mkIface_ hsc_env maybe_old_fingerprint
               mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
               mi_rules       = sortBy cmp_rule     iface_rules,
 
-              mi_vect_info   = iface_vect_info,
-
               mi_fixities    = fixities,
               mi_warns       = warns,
               mi_anns        = annotations,
@@ -277,7 +301,10 @@ mkIface_ hsc_env maybe_old_fingerprint
               mi_iface_hash  = fingerprint0,
               mi_mod_hash    = fingerprint0,
               mi_flag_hash   = fingerprint0,
+              mi_opt_hash    = fingerprint0,
+              mi_hpc_hash    = fingerprint0,
               mi_exp_hash    = fingerprint0,
+              mi_plugin_hash = fingerprint0,
               mi_used_th     = used_th,
               mi_orphan_hash = fingerprint0,
               mi_orphan      = False, -- Always set by addFingerprints, but
@@ -292,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint
               -- And build the cached values
               mi_warn_fn     = mkIfaceWarnCache warns,
               mi_fix_fn      = mkIfaceFixCache fixities,
-              mi_complete_sigs = icomplete_sigs }
+              mi_complete_sigs = icomplete_sigs,
+              mi_doc_hdr     = doc_hdr,
+              mi_decl_docs   = decl_docs,
+              mi_arg_docs    = arg_docs }
 
     (new_iface, no_change_at_all)
           <- {-# SCC "versioninfo" #-}
@@ -335,19 +365,6 @@ mkIface_ hsc_env maybe_old_fingerprint
 
      ifFamInstTcName = ifFamInstFam
 
-     flattenVectInfo (VectInfo { vectInfoVar            = vVar
-                               , vectInfoTyCon          = vTyCon
-                               , vectInfoParallelVars     = vParallelVars
-                               , vectInfoParallelTyCons = vParallelTyCons
-                               }) =
-       IfaceVectInfo
-       { ifaceVectInfoVar            = [Var.varName v | (v, _  ) <- dVarEnvElts vVar]
-       , ifaceVectInfoTyCon          = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
-       , ifaceVectInfoTyConReuse     = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
-       , ifaceVectInfoParallelVars   = [Var.varName v | v <- dVarSetElems vParallelVars]
-       , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons
-       }
-
 -----------------------------
 writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
 writeIfaceFile dflags hi_file_path new_iface
@@ -658,18 +675,22 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    -- the abi hash and one that should
    flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
 
+   opt_hash <- fingerprintOptFlags dflags putNameLiterally
+
+   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+
+   plugin_hash <- fingerprintPlugins hsc_env
+
    -- the ABI hash depends on:
    --   - decls
    --   - export list
    --   - orphans
    --   - deprecations
-   --   - vect info
    --   - flag abi hash
    mod_hash <- computeFingerprint putNameLiterally
                       (map fst sorted_decls,
                        export_hash,  -- includes orphan_hash
-                       mi_warns iface0,
-                       mi_vect_info iface0)
+                       mi_warns iface0)
 
    -- The interface hash depends on:
    --   - the ABI hash, plus
@@ -693,11 +714,13 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_exp_hash    = export_hash,
                 mi_orphan_hash = orphan_hash,
                 mi_flag_hash   = flag_hash,
+                mi_opt_hash    = opt_hash,
+                mi_hpc_hash    = hpc_hash,
+                mi_plugin_hash = plugin_hash,
                 mi_orphan      = not (   all ifRuleAuto orph_rules
                                            -- See Note [Orphans and auto-generated rules]
                                       && null orph_insts
-                                      && null orph_fis
-                                      && isNoIfaceVectInfo (mi_vect_info iface0)),
+                                      && null orph_fis),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
                 mi_decls       = sorted_decls,
                 mi_hash_fn     = lookupOccEnv local_env }
@@ -768,7 +791,8 @@ sortDependencies d
  = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
           dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),
           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
-          dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),
+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
 
 -- | Creates cached lookup for the 'mi_anns' field of ModIface
 -- Hackily, we use "module" as the OccName for any module-level annotations
@@ -989,7 +1013,7 @@ mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
                                 --      each sublist in canonical order
               [decl])           -- Orphan decls; in canonical order
 mkOrphMap get_key decls
-  = foldl go (emptyOccEnv, []) decls
+  = foldl' go (emptyOccEnv, []) decls
   where
     go (non_orphs, orphs) d
         | NotOrphan occ <- get_key d
@@ -1082,6 +1106,16 @@ data RecompileRequired
        -- to force recompilation; the String says what (one-line summary)
    deriving Eq
 
+instance Semigroup RecompileRequired where
+  UpToDate <> r = r
+  mc <> _       = mc
+
+instance Monoid RecompileRequired where
+  mempty = UpToDate
+#if __GLASGOW_HASKELL__ < 804
+  mappend = (Data.Semigroup.<>)
+#endif
+
 recompileRequired :: RecompileRequired -> Bool
 recompileRequired UpToDate = False
 recompileRequired _ = True
@@ -1198,12 +1232,19 @@ checkVersions hsc_env mod_summary iface
             then return (RecompBecause "-this-unit-id changed", Nothing) else do {
        ; recomp <- checkFlagHash hsc_env iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkOptimHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHpcHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- checkMergedSignatures mod_summary iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- checkHsig mod_summary iface
        ; if recompileRequired recomp then return (recomp, Nothing) else do {
        ; recomp <- checkDependencies hsc_env mod_summary iface
        ; if recompileRequired recomp then return (recomp, Just iface) else do {
+       ; recomp <- checkPlugins hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
 
        -- Source code unchanged and no errors yet... carry on
        --
@@ -1221,13 +1262,51 @@ checkVersions hsc_env mod_summary iface
        ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
        ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
        ; return (recomp, Just iface)
-    }}}}}}
+    }}}}}}}}}
   where
     this_pkg = thisPackage (hsc_dflags hsc_env)
     -- This is a bit of a hack really
     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
     mod_deps = mkModDeps (dep_mods (mi_deps iface))
 
+-- | Check if any plugins are requesting recompilation
+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
+checkPlugins hsc iface = liftIO $ do
+  -- [(ModuleName, Plugin, [Opts])]
+  let old_fingerprint = mi_plugin_hash iface
+      loaded_plugins = plugins (hsc_dflags hsc)
+  res <- mconcat <$> mapM checkPlugin loaded_plugins
+  return (pluginRecompileToRecompileRequired old_fingerprint res)
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+  fingerprintPlugins' (plugins (hsc_dflags hsc_env))
+
+fingerprintPlugins' :: [LoadedPlugin] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+  res <- mconcat <$> mapM checkPlugin plugins
+  return $ case res of
+      NoForceRecompile ->  fingerprintString "NoForceRecompile"
+      ForceRecompile   -> fingerprintString "ForceRecompile"
+      -- is the chance of collision worth worrying about?
+      -- An alternative is to fingerprintFingerprints [fingerprintString
+      -- "maybeRecompile", fp]
+      (MaybeRecompile fp) -> fp
+
+
+
+checkPlugin :: LoadedPlugin -> IO PluginRecompile
+checkPlugin (LoadedPlugin plugin _ opts) = pluginRecompile plugin opts
+
+pluginRecompileToRecompileRequired :: Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp pr =
+  case pr of
+    NoForceRecompile -> UpToDate
+    ForceRecompile   -> RecompBecause "Plugin forced recompilation"
+    MaybeRecompile fp  -> if fp == old_fp then UpToDate
+                                          else RecompBecause "Plugin fingerprint changed"
+
+
 -- | Check if an hsig file needs recompilation because its
 -- implementing module has changed.
 checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
@@ -1253,6 +1332,36 @@ checkFlagHash hsc_env iface = do
                      (text "  Module flags have changed")
                      old_hash new_hash
 
+-- | Check the optimisation flags haven't changed
+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkOptimHash hsc_env iface = do
+    let old_hash = mi_opt_hash iface
+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "Optimisation flags unchanged")
+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "Optimisation flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "Optimisation flags changed"
+                     (text "  Optimisation flags have changed")
+                     old_hash new_hash
+
+-- | Check the HPC flags haven't changed
+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkHpcHash hsc_env iface = do
+    let old_hash = mi_hpc_hash iface
+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "HPC flags unchanged")
+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "HPC flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "HPC flags changed"
+                     (text "  HPC flags have changed")
+                     old_hash new_hash
+
 -- Check that the set of signatures we are merging in match.
 -- If the -unit-id flags change, this can change too.
 checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
@@ -1282,6 +1391,7 @@ checkDependencies hsc_env summary iface
  = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
   where
    prev_dep_mods = dep_mods (mi_deps iface)
+   prev_dep_plgn = dep_plgins (mi_deps iface)
    prev_dep_pkgs = dep_pkgs (mi_deps iface)
 
    this_pkg = thisPackage (hsc_dflags hsc_env)
@@ -1292,7 +1402,7 @@ checkDependencies hsc_env summary iface
      case find_res of
         Found _ mod
           | pkg == this_pkg
-           -> if moduleName mod `notElem` map fst prev_dep_mods
+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
                  then do traceHiDiffs $
                            text "imported module " <> quotes (ppr mod) <>
                            text " not among previous dependencies"
@@ -1536,7 +1646,7 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
                   , ifaxbRHS     = tidyToIfaceType env1 rhs
                   , ifaxbIncomps = [] }
   where
-    (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs
+    (env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs
     -- Don't re-bind in-scope tyvars
     -- See Note [CoAxBranch type variables] in CoAxiom
 
@@ -1565,7 +1675,7 @@ tyConToIfaceDecl env tycon
                     ifFamFlav = to_if_fam_flav fam_flav,
                     ifBinders = if_binders,
                     ifResKind = if_res_kind,
-                    ifFamInj  = familyTyConInjectivityInfo tycon
+                    ifFamInj  = tyConInjectivityInfo tycon
                   })
 
   | isAlgTyCon tycon
@@ -1600,7 +1710,7 @@ tyConToIfaceDecl env tycon
     -- an error.
     (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
     tc_tyvars      = binderVars tc_binders
-    if_binders     = toIfaceTyVarBinders tc_binders
+    if_binders     = toIfaceTyCoVarBinders tc_binders
     if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)
     if_syn_type ty = tidyToIfaceType tc_env1 ty
     if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon
@@ -1641,7 +1751,8 @@ tyConToIfaceDecl env tycon
         = IfCon   { ifConName    = dataConName data_con,
                     ifConInfix   = dataConIsInfix data_con,
                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                    ifConExTvs   = map toIfaceForAllBndr ex_bndrs',
+                    ifConExTCvs  = map toIfaceBndr ex_tvs',
+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
                     ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
@@ -1651,9 +1762,9 @@ tyConToIfaceDecl env tycon
                     ifConSrcStricts = map toIfaceSrcBang
                                           (dataConSrcBangs data_con)}
         where
-          (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
             = dataConFullSig data_con
-          ex_bndrs = dataConExTyVarBinders data_con
+          user_bndrs = dataConUserTyVarBinders data_con
 
           -- Tidy the univ_tvs of the data constructor to be identical
           -- to the tyConTyVars of the type constructor.  This means
@@ -1665,15 +1776,27 @@ tyConToIfaceDecl env tycon
           con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
                      -- A bit grimy, perhaps, but it's simple!
 
-          (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
+          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
           to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
 
+          -- By this point, we have tidied every universal and existential
+          -- tyvar. Because of the dcUserTyCoVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every*
+          -- user-written tyvar must be contained in the substitution that
+          -- tidying produced. Therefore, tidying the user-written tyvars is a
+          -- simple matter of looking up each variable in the substitution,
+          -- which tidyTyCoVarOcc accomplishes.
+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
+          tidyUserTyCoVarBinder env (Bndr tv vis) =
+            Bndr (tidyTyCoVarOcc env tv) vis
+
 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
 classToIfaceDecl env clas
   = ( env1
     , IfaceClass { ifName   = getName tycon,
                    ifRoles  = tyConRoles (classTyCon clas),
-                   ifBinders = toIfaceTyVarBinders tc_binders,
+                   ifBinders = toIfaceTyCoVarBinders tc_binders,
                    ifBody   = body,
                    ifFDs    = map toIfaceFD clas_fds })
   where
@@ -1725,10 +1848,10 @@ tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
 -- If the type variable "binder" is in scope, don't re-bind it
 -- In a class decl, for example, the ATD binders mention
 -- (amd must mention) the class tyvars
-tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)
+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
  = case lookupVarEnv subst tv of
-     Just tv' -> (env,  TvBndr tv' vis)
-     Nothing  -> tidyTyVarBinder env tvb
+     Just tv' -> (env,  Bndr tv' vis)
+     Nothing  -> tidyTyCoVarBinder env tvb
 
 tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
 tidyTyConBinders = mapAccumL tidyTyConBinder
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 1477f462fc..248f7d3c38 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -15,13 +15,15 @@ module TcIface (
         typecheckIfacesForMerging,
         typecheckIfaceForInstantiate,
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
-        tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs,
+        tcIfaceAnnotations, tcIfaceCompleteSigs,
         tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
         tcIfaceGlobal
  ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcTypeNats(typeNatCoAxiomRules)
 import IfaceSyn
 import LoadIface
@@ -53,7 +55,6 @@ import PrelNames
 import TysWiredIn
 import Literal
 import Var
-import VarEnv
 import VarSet
 import Name
 import NameEnv
@@ -74,7 +75,6 @@ import ListSetOps
 import GHC.Fingerprint
 import qualified BooleanFormula as BF
 
-import Data.List
 import Control.Monad
 import qualified Data.Map as Map
 
@@ -171,9 +171,6 @@ typecheckIface iface
         ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
         ; anns      <- tcIfaceAnnotations (mi_anns iface)
 
-                -- Vectorisation information
-        ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
-
                 -- Exports
         ; exports <- ifaceExportNames (mi_exports iface)
 
@@ -191,7 +188,6 @@ typecheckIface iface
                               , md_fam_insts = fam_insts
                               , md_rules     = rules
                               , md_anns      = anns
-                              , md_vect_info = vect_info
                               , md_exports   = exports
                               , md_complete_sigs = complete_sigs
                               }
@@ -391,7 +387,6 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
         fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
         rules     <- tcIfaceRules ignore_prags (mi_rules iface)
         anns      <- tcIfaceAnnotations (mi_anns iface)
-        vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
         exports   <- ifaceExportNames (mi_exports iface)
         complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
         return $ ModDetails { md_types     = type_env
@@ -399,7 +394,6 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
                             , md_fam_insts = fam_insts
                             , md_rules     = rules
                             , md_anns      = anns
-                            , md_vect_info = vect_info
                             , md_exports   = exports
                             , md_complete_sigs = complete_sigs
                             }
@@ -432,7 +426,6 @@ typecheckIfaceForInstantiate nsubst iface =
     fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
     rules     <- tcIfaceRules ignore_prags (mi_rules iface)
     anns      <- tcIfaceAnnotations (mi_anns iface)
-    vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
     exports   <- ifaceExportNames (mi_exports iface)
     complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
     return $ ModDetails { md_types     = type_env
@@ -440,7 +433,6 @@ typecheckIfaceForInstantiate nsubst iface =
                         , md_fam_insts = fam_insts
                         , md_rules     = rules
                         , md_anns      = anns
-                        , md_vect_info = vect_info
                         , md_exports   = exports
                         , md_complete_sigs = complete_sigs
                         }
@@ -645,7 +637,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
                                        ifIdDetails = details, ifIdInfo = info})
   = do  { ty <- tcIfaceType iface_type
         ; details <- tcIdDetails ty details
-        ; info <- tcIdInfo ignore_prags name ty info
+        ; info <- tcIdInfo ignore_prags TopLevel name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
 
 tc_iface_decl _ _ (IfaceData {ifName = tc_name,
@@ -677,7 +669,7 @@ tc_iface_decl _ _ (IfaceData {ifName = tc_name,
       = do { ax <- tcIfaceCoAxiom ax_name
            ; let fam_tc  = coAxiomTyCon ax
                  ax_unbr = toUnbranchedAxiom ax
-           ; lhs_tys <- tcIfaceTcArgs arg_tys
+           ; lhs_tys <- tcIfaceAppArgs arg_tys
            ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
 
 tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
@@ -869,10 +861,10 @@ tc_ax_branch prev_branches
                             , ifaxbLHS = lhs, ifaxbRHS = rhs
                             , ifaxbRoles = roles, ifaxbIncomps = incomps })
   = bindIfaceTyConBinders_AT
-      (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
+      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
          -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
     bindIfaceIds cv_bndrs $ \ cvs -> do
-    { tc_lhs <- tcIfaceTcArgs lhs
+    { tc_lhs <- tcIfaceAppArgs lhs
     ; tc_rhs <- tcIfaceType rhs
     ; let br = CoAxBranch { cab_loc     = noSrcSpan
                           , cab_tvs     = binderVars tvs
@@ -892,11 +884,15 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
         IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con
                                 ; mkNewTyConRhs tycon_name tycon data_con }
   where
-    univ_tv_bndrs :: [TyVarBinder]
-    univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
+    univ_tvs :: [TyVar]
+    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
+
+    tag_map :: NameEnv ConTag
+    tag_map = mkTyConTagMap tycon
 
     tc_con_decl (IfCon { ifConInfix = is_infix,
-                         ifConExTvs = ex_bndrs,
+                         ifConExTCvs = ex_bndrs,
+                         ifConUserTvBinders = user_bndrs,
                          ifConName = dc_name,
                          ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = lbl_names,
@@ -904,9 +900,23 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
                          ifConSrcStricts = if_src_stricts})
      = -- Universally-quantified tyvars are shared with
        -- parent TyCon, and are already in scope
-       bindIfaceForAllBndrs ex_bndrs    $ \ ex_tv_bndrs -> do
+       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do
         { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
 
+          -- By this point, we have bound every universal and existential
+          -- tyvar. Because of the dcUserTyVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every* tyvar in
+          -- ifConUserTvBinders has a matching counterpart somewhere in the
+          -- bound universals/existentials. As a result, calling tcIfaceTyVar
+          -- below is always guaranteed to succeed.
+        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->
+                                   case bd of
+                                     IfaceIdBndr (name, _) ->
+                                       Bndr <$> tcIfaceLclId name <*> pure vis
+                                     IfaceTvBndr (name, _) ->
+                                       Bndr <$> tcIfaceTyVar name <*> pure vis)
+                                user_bndrs
+
         -- Read the context and argument types, but lazily for two reasons
         -- (a) to avoid looking tugging on a recursive use of
         --     the type itself, which is knot-tied
@@ -915,7 +925,14 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
         ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
              do { eq_spec <- tcIfaceEqSpec spec
                 ; theta   <- tcIfaceCtxt ctxt
-                ; arg_tys <- mapM tcIfaceType args
+                -- This fixes #13710.  The enclosing lazy thunk gets
+                -- forced when typechecking record wildcard pattern
+                -- matching (it's not completely clear why this
+                -- tuple is needed), which causes trouble if one of
+                -- the argument types was recursively defined.
+                -- See also Note [Tying the knot]
+                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
+                           $ mapM tcIfaceType args
                 ; stricts <- mapM tc_strict if_stricts
                         -- The IfBang field can mention
                         -- the type itself; hence inside forkM
@@ -923,7 +940,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
 
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon
-                                (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
+                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
                                              (binderVars tc_tybinders))
 
         ; prom_rep_name <- newTyConRepName dc_name
@@ -938,9 +955,9 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
                        -- worker.
                        -- See Note [Bangs on imported data constructors] in MkId
                        lbl_names
-                       univ_tv_bndrs ex_tv_bndrs
+                       univ_tvs ex_tvs user_tv_bndrs
                        eq_spec theta
-                       arg_tys orig_res_ty tycon
+                       arg_tys orig_res_ty tycon tag_map
         ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
         ; return con }
     mk_doc con_name = text "Constructor" <+> ppr con_name
@@ -1060,7 +1077,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
         -- to write them out in coreRuleToIfaceRule
     ifTopFreeName :: IfaceExpr -> Maybe Name
     ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
-    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
     ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
     ifTopFreeName (IfaceExt n)                      = Just n
     ifTopFreeName _                                 = Nothing
@@ -1108,134 +1125,6 @@ tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
 {-
 ************************************************************************
 *                                                                      *
-                Vectorisation information
-*                                                                      *
-************************************************************************
--}
-
--- We need access to the type environment as we need to look up information about type constructors
--- (i.e., their data constructors and whether they are class type constructors).  If a vectorised
--- type constructor or class is defined in the same module as where it is vectorised, we cannot
--- look that information up from the type constructor that we obtained via a 'forkM'ed
--- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
--- and again and again...
---
-tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
-tcIfaceVectInfo mod typeEnv (IfaceVectInfo
-                             { ifaceVectInfoVar            = vars
-                             , ifaceVectInfoTyCon          = tycons
-                             , ifaceVectInfoTyConReuse     = tyconsReuse
-                             , ifaceVectInfoParallelVars   = parallelVars
-                             , ifaceVectInfoParallelTyCons = parallelTyCons
-                             })
-  = do { let parallelTyConsSet = mkNameSet parallelTyCons
-       ; vVars         <- mapM vectVarMapping                  vars
-       ; let varsSet = mkVarSet (map fst vVars)
-       ; tyConRes1     <- mapM (vectTyConVectMapping varsSet)  tycons
-       ; tyConRes2     <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
-       ; vParallelVars <- mapM vectVar                         parallelVars
-       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
-       ; return $ VectInfo
-                  { vectInfoVar            = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
-                  , vectInfoTyCon          = mkNameEnv vTyCons
-                  , vectInfoDataCon        = mkNameEnv (concat vDataCons)
-                  , vectInfoParallelVars   = mkDVarSet vParallelVars
-                  , vectInfoParallelTyCons = parallelTyConsSet
-                  }
-       }
-  where
-    vectVarMapping name
-      = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
-           ; var   <- forkM (text "vect var"  <+> ppr name)  $
-                        tcIfaceExtId name
-           ; vVar  <- forkM (text "vect vVar [mod =" <+>
-                             ppr mod <> text "; nameModule =" <+>
-                             ppr (nameModule name) <> text "]" <+> ppr vName) $
-                       tcIfaceExtId vName
-           ; return (var, (var, vVar))
-           }
-      -- where
-      --   lookupLocalOrExternalId name
-      --     = do { let mb_id = lookupTypeEnv typeEnv name
-      --          ; case mb_id of
-      --                -- id is local
-      --              Just (AnId id) -> return id
-      --                -- name is not an Id => internal inconsistency
-      --              Just _         -> notAnIdErr
-      --                -- Id is external
-      --              Nothing        -> tcIfaceExtId name
-      --          }
-      --
-      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
-
-    vectVar name
-      = forkM (text "vect scalar var"  <+> ppr name)  $
-          tcIfaceExtId name
-
-    vectTyConVectMapping vars name
-      = do { vName  <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
-           ; vectTyConMapping vars name vName
-           }
-
-    vectTyConReuseMapping vars name
-      = vectTyConMapping vars name name
-
-    vectTyConMapping vars name vName
-      = do { tycon  <- lookupLocalOrExternalTyCon name
-           ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $
-                         lookupLocalOrExternalTyCon vName
-
-               -- Map the data constructors of the original type constructor to those of the
-               -- vectorised type constructor /unless/ the type constructor was vectorised
-               -- abstractly; if it was vectorised abstractly, the workers of its data constructors
-               -- do not appear in the set of vectorised variables.
-               --
-               -- NB: This is lazy!  We don't pull at the type constructors before we actually use
-               --     the data constructor mapping.
-           ; let isAbstract | isClassTyCon tycon = False
-                            | datacon:_ <- tyConDataCons tycon
-                                                 = not $ dataConWrapId datacon `elemVarSet` vars
-                            | otherwise          = True
-                 vDataCons  | isAbstract = []
-                            | otherwise  = [ (dataConName datacon, (datacon, vDatacon))
-                                           | (datacon, vDatacon) <- zip (tyConDataCons tycon)
-                                                                        (tyConDataCons vTycon)
-                                           ]
-
-                   -- Map the (implicit) superclass and methods selectors as they don't occur in
-                   -- the var map.
-                 vScSels    | Just cls  <- tyConClass_maybe tycon
-                            , Just vCls <- tyConClass_maybe vTycon
-                            = [ (sel, (sel, vSel))
-                              | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
-                              ]
-                            | otherwise
-                            = []
-
-           ; return ( (name, (tycon, vTycon))          -- (T, T_v)
-                    , vDataCons                        -- list of (Ci, Ci_v)
-                    , vScSels                          -- list of (seli, seli_v)
-                    )
-           }
-      where
-          -- we need a fully defined version of the type constructor to be able to extract
-          -- its data constructors etc.
-        lookupLocalOrExternalTyCon name
-          = do { let mb_tycon = lookupTypeEnv typeEnv name
-               ; case mb_tycon of
-                     -- tycon is local
-                   Just (ATyCon tycon) -> return tycon
-                     -- name is not a tycon => internal inconsistency
-                   Just _              -> notATyConErr
-                     -- tycon is external
-                   Nothing             -> tcIfaceTyConByName name
-               }
-
-        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
-
-{-
-************************************************************************
-*                                                                      *
                         Types
 *                                                                      *
 ************************************************************************
@@ -1246,24 +1135,27 @@ tcIfaceType = go
   where
     go (IfaceTyVar n)         = TyVarTy <$> tcIfaceTyVar n
     go (IfaceFreeTyVar n)     = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
-    go (IfaceAppTy t1 t2)     = AppTy <$> go t1 <*> go t2
     go (IfaceLitTy l)         = LitTy <$> tcIfaceTyLit l
     go (IfaceFunTy t1 t2)     = FunTy <$> go t1 <*> go t2
     go (IfaceDFunTy t1 t2)    = FunTy <$> go t1 <*> go t2
     go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
+    go (IfaceAppTy t ts)
+      = do { t'  <- go t
+           ; ts' <- traverse go (appArgsIfaceTypes ts)
+           ; pure (foldl' AppTy t' ts') }
     go (IfaceTyConApp tc tks)
       = do { tc' <- tcIfaceTyCon tc
-           ; tks' <- mapM go (tcArgsIfaceTypes tks)
+           ; tks' <- mapM go (appArgsIfaceTypes tks)
            ; return (mkTyConApp tc' tks') }
     go (IfaceForAllTy bndr t)
       = bindIfaceForAllBndr bndr $ \ tv' vis ->
-        ForAllTy (TvBndr tv' vis) <$> go t
+        ForAllTy (Bndr tv' vis) <$> go t
     go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
     go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
 
-tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
+tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
 tcIfaceTupleTy sort is_promoted args
- = do { args' <- tcIfaceTcArgs args
+ = do { args' <- tcIfaceAppArgs args
       ; let arity = length args'
       ; base_tc <- tcTupleTyCon True sort arity
       ; case is_promoted of
@@ -1290,8 +1182,8 @@ tcTupleTyCon in_type sort arity
                      | otherwise = arity
                       -- in expressions, we only have term args
 
-tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
-tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
+tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
 
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
@@ -1313,13 +1205,17 @@ tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
 tcIfaceCo :: IfaceCoercion -> IfL Coercion
 tcIfaceCo = go
   where
-    go (IfaceReflCo r t)         = Refl r <$> tcIfaceType t
+    go_mco IfaceMRefl    = pure MRefl
+    go_mco (IfaceMCo co) = MCo <$> (go co)
+
+    go (IfaceReflCo t)           = Refl <$> tcIfaceType t
+    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco
     go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2
     go (IfaceTyConAppCo r tc cs)
       = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
     go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2
     go (IfaceForAllCo tv k c)  = do { k' <- go k
-                                      ; bindIfaceTyVar tv $ \ tv' ->
+                                      ; bindIfaceBndr tv $ \ tv' ->
                                         ForAllCo tv' k' <$> go c }
     go (IfaceCoVarCo n)          = CoVarCo <$> go_var n
     go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
@@ -1330,31 +1226,24 @@ tcIfaceCo = go
                                             <*> go c2
     go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
                                             <*> go t2
-    go (IfaceNthCo d c)          = NthCo d  <$> go c
+    go (IfaceNthCo d c)          = do { c' <- go c
+                                      ; return $ mkNthCo (nthCoRole d c') d c' }
     go (IfaceLRCo lr c)          = LRCo lr  <$> go c
-    go (IfaceCoherenceCo c1 c2)  = CoherenceCo <$> go c1
-                                               <*> go c2
     go (IfaceKindCo c)           = KindCo   <$> go c
     go (IfaceSubCo c)            = SubCo    <$> go c
-    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax
+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
                                                <*> mapM go cos
+    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
+    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
 
     go_var :: FastString -> IfL CoVar
     go_var = tcIfaceLclId
 
-    go_axiom_rule :: FastString -> IfL CoAxiomRule
-    go_axiom_rule n =
-      case Map.lookup n typeNatCoAxiomRules of
-        Just ax -> return ax
-        _  -> pprPanic "go_axiom_rule" (ppr n)
-
 tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
 tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv
 tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco
 tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
 tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str
-tcIfaceUnivCoProv (IfaceHoleProv _)         =
-    pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files")
 
 {-
 ************************************************************************
@@ -1396,7 +1285,7 @@ tcIfaceExpr (IfaceTuple sort args)
        ; let con_tys = map exprType args'
              some_con_args = map Type con_tys ++ args'
              con_args = case sort of
-               UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args
+               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
                _            -> some_con_args
                         -- Put the missing type arguments back in
              con_id   = dataConWorkId (tyConSingleDataCon tc)
@@ -1440,7 +1329,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
   = do  { name    <- newIfaceName (mkVarOccFS fs)
         ; ty'     <- tcIfaceType ty
         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
-                              name ty' info
+                              NotTopLevel name ty' info
         ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
                      `asJoinId_maybe` tcJoinInfo ji
         ; rhs' <- tcIfaceExpr rhs
@@ -1461,7 +1350,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
    tc_pair (IfLetBndr _ _ info _, rhs) id
      = do { rhs' <- tcIfaceExpr rhs
           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
-                                (idName id) (idType id) info
+                                NotTopLevel (idName id) (idType id) info
           ; return (setIdInfo id id_info, rhs') }
 
 tcIfaceExpr (IfaceTick tickish expr) = do
@@ -1486,9 +1375,15 @@ tcIfaceLit :: Literal -> IfL Literal
 -- Integer literals deserialise to (LitInteger i <error thunk>)
 -- so tcIfaceLit just fills in the type.
 -- See Note [Integer literals] in Literal
-tcIfaceLit (LitInteger i _)
+tcIfaceLit (LitNumber LitNumInteger i _)
   = do t <- tcIfaceTyConByName integerTyConName
        return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+  = do t <- tcIfaceTyConByName naturalTyConName
+       return (mkLitNatural i (mkTyConTy t))
 tcIfaceLit lit = return lit
 
 -------------------------
@@ -1552,8 +1447,8 @@ tcIdDetails _ (IfRecSelId tc naughty)
     tyThingPatSyn (AConLike (PatSynCon ps)) = ps
     tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
 
-tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
-tcIdInfo ignore_prags name ty info = do
+tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags toplvl name ty info = do
     lcl_env <- getLclEnv
     -- Set the CgInfo to something sensible but uninformative before
     -- we start; default assumption is that it has CAFs
@@ -1574,7 +1469,7 @@ tcIdInfo ignore_prags name ty info = do
 
         -- The next two are lazy, so they don't transitively suck stuff in
     tcPrag info (HsUnfold lb if_unf)
-      = do { unf <- tcUnfolding name ty info if_unf
+      = do { unf <- tcUnfolding toplvl name ty info if_unf
            ; let info1 | lb        = info `setOccInfo` strongLoopBreaker
                        | otherwise = info
            ; return (info1 `setUnfoldingInfo` unf) }
@@ -1583,10 +1478,10 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
 tcJoinInfo (IfaceJoinPoint ar) = Just ar
 tcJoinInfo IfaceNotJoinPoint   = Nothing
 
-tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ info (IfCoreUnfold stable if_expr)
+tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
   = do  { dflags <- getDynFlags
-        ; mb_expr <- tcPragExpr name if_expr
+        ; mb_expr <- tcPragExpr toplvl name if_expr
         ; let unf_src | stable    = InlineStable
                       | otherwise = InlineRhs
         ; return $ case mb_expr of
@@ -1599,21 +1494,21 @@ tcUnfolding name _ info (IfCoreUnfold stable if_expr)
   where
      -- Strictness should occur before unfolding!
     strict_sig = strictnessInfo info
-tcUnfolding name _ _ (IfCompulsory if_expr)
-  = do  { mb_expr <- tcPragExpr name if_expr
+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
         ; return (case mb_expr of
                     Nothing   -> NoUnfolding
                     Just expr -> mkCompulsoryUnfolding expr) }
 
-tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
-  = do  { mb_expr <- tcPragExpr name if_expr
+tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
         ; return (case mb_expr of
                     Nothing   -> NoUnfolding
                     Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
   where
     guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
 
-tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
+tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
   = bindIfaceBndrs bs $ \ bs' ->
     do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
        ; return (case mb_ops1 of
@@ -1628,13 +1523,14 @@ For unfoldings we try to do the job lazily, so that we never type check
 an unfolding that isn't going to be looked at.
 -}
 
-tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
-tcPragExpr name expr
+tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr toplvl name expr
   = forkM_maybe doc $ do
     core_expr' <- tcIfaceExpr expr
 
-                -- Check for type consistency in the unfolding
-    whenGOptM Opt_DoCoreLinting $ do
+    -- Check for type consistency in the unfolding
+    -- See Note [Linting Unfoldings from Interfaces]
+    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
         in_scope <- get_in_scope
         dflags   <- getDynFlags
         case lintUnfolding dflags noSrcLoc in_scope core_expr' of
@@ -1692,13 +1588,13 @@ tcIfaceGlobal name
                 { type_env <- setLclEnv () get_type_env         -- yuk
                 ; case lookupNameEnv type_env name of
                     Just thing -> return thing
-                    Nothing   ->
-                      pprPanic "tcIfaceGlobal (local): not found"
-                               (ifKnotErr name (if_doc env) type_env)
+                    -- See Note [Knot-tying fallback on boot]
+                    Nothing   -> via_external
                 }
 
-          ; _ -> do
-
+          ; _ -> via_external }}
+  where
+    via_external =  do
         { hsc_env <- getTopEnv
         ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
         ; case mb_thing of {
@@ -1709,21 +1605,7 @@ tcIfaceGlobal name
         ; case mb_thing of
             Failed err      -> failIfM err
             Succeeded thing -> return thing
-    }}}}}
-
-ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc
-ifKnotErr name env_doc type_env = vcat
-  [ text "You are in a maze of twisty little passages, all alike."
-  , text "While forcing the thunk for TyThing" <+> ppr name
-  , text "which was lazily initialized by" <+> env_doc <> text ","
-  , text "I tried to tie the knot, but I couldn't find" <+> ppr name
-  , text "in the current type environment."
-  , text "If you are developing GHC, please read Note [Tying the knot]"
-  , text "and Note [Type-checking inside the knot]."
-  , text "Consider rebuilding GHC with profiling for a better stack trace."
-  , hang (text "Contents of current type environment:")
-       2 (ppr type_env)
-  ]
+        }}}
 
 -- Note [Tying the knot]
 -- ~~~~~~~~~~~~~~~~~~~~~
@@ -1738,11 +1620,50 @@ ifKnotErr name env_doc type_env = vcat
 --      * Note [Knot-tying typecheckIface]
 --      * Note [DFun knot-tying]
 --      * Note [hsc_type_env_var hack]
+--      * Note [Knot-tying fallback on boot]
 --
 -- There is also a wiki page on the subject, see:
 --
 --      https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
 
+-- Note [Knot-tying fallback on boot]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Suppose that you are typechecking A.hs, which transitively imports,
+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
+-- has a reference to a type T from A, what TyThing should we wire
+-- it up with? Clearly, if we have already typechecked T and
+-- added it into the type environment, we should go ahead and use that
+-- type. But what if we haven't typechecked it yet?
+--
+-- For the longest time, GHC adopted the policy that this was
+-- *an error condition*; that you MUST NEVER poke on B.hs's reference
+-- to a T defined in A.hs until A.hs has gotten around to kind-checking
+-- T and adding it to the env. However, actually ensuring this is the
+-- case has proven to be a bug farm, because it's really difficult to
+-- actually ensure this never happens. The problem was especially poignant
+-- with type family consistency checks, which eagerly happen before any
+-- typechecking takes place.
+--
+-- Today, we take a different strategy: if we ever try to access
+-- an entity from A which doesn't exist, we just fall back on the
+-- definition of A from the hs-boot file. This is complicated in
+-- its own way: it means that you may end up with a mix of A.hs and
+-- A.hs-boot TyThings during the course of typechecking.  We don't
+-- think (and have not observed) any cases where this would cause
+-- problems, but the hypothetical situation one might worry about
+-- is something along these lines in Core:
+--
+--    case x of
+--        A -> e1
+--        B -> e2
+--
+-- If, when typechecking this, we find x :: T, and the T we are hooked
+-- up with is the abstract one from the hs-boot file, rather than the
+-- one defined in this module with constructors A and B.  But it's hard
+-- to see how this could happen, especially because the reference to
+-- the constructor (A and B) means that GHC will always typecheck
+-- this expression *after* typechecking T.
+
 tcIfaceTyConByName :: IfExtName -> IfL TyCon
 tcIfaceTyConByName name
   = do { thing <- tcIfaceGlobal name
@@ -1759,6 +1680,16 @@ tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
 tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
                          ; return (tyThingCoAxiom thing) }
 
+
+tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
+-- Unlike CoAxioms, which arise form user 'type instance' declarations,
+-- there are a fixed set of CoAxiomRules,
+-- currently enumerated in typeNatCoAxiomRules
+tcIfaceCoAxiomRule n
+  = case Map.lookup n typeNatCoAxiomRules of
+        Just ax -> return ax
+        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
+
 tcIfaceDataCon :: Name -> IfL DataCon
 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
                          ; case thing of
@@ -1818,16 +1749,18 @@ bindIfaceBndrs (b:bs) thing_inside
     thing_inside (b':bs')
 
 -----------------------
-bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a
 bindIfaceForAllBndrs [] thing_inside = thing_inside []
 bindIfaceForAllBndrs (bndr:bndrs) thing_inside
   = bindIfaceForAllBndr bndr $ \tv vis ->
     bindIfaceForAllBndrs bndrs $ \bndrs' ->
-    thing_inside (mkTyVarBinder vis tv : bndrs')
+    thing_inside (mkTyCoVarBinder vis tv : bndrs')
 
-bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
-bindIfaceForAllBndr (TvBndr tv vis) thing_inside
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
   = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
+  = bindIfaceId tv $ \tv' -> thing_inside tv' vis
 
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside
@@ -1844,8 +1777,8 @@ bindIfaceTyConBinders :: [IfaceTyConBinder]
                       -> ([TyConBinder] -> IfL a) -> IfL a
 bindIfaceTyConBinders [] thing_inside = thing_inside []
 bindIfaceTyConBinders (b:bs) thing_inside
-  = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b'  ->
-    bindIfaceTyConBinders bs               $ \ bs' ->
+  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->
+    bindIfaceTyConBinders bs              $ \ bs' ->
     thing_inside (b':bs')
 
 bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
@@ -1862,14 +1795,14 @@ bindIfaceTyConBinders_AT (b : bs) thing_inside
     thing_inside (b':bs')
   where
     bind_tv tv thing
-      = do { mb_tv <- lookupIfaceTyVar tv
+      = do { mb_tv <- lookupIfaceVar tv
            ; case mb_tv of
                Just b' -> thing b'
-               Nothing -> bindIfaceTyVar tv thing }
+               Nothing -> bindIfaceBndr tv thing }
 
-bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
+bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
                       -> IfaceTyConBinder
                       -> (TyConBinder -> IfL a) -> IfL a
-bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
   = bind_tv tv $ \tv' ->
-    thing_inside (TvBndr tv' vis)
+    thing_inside (Bndr tv' vis)
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
index 4a99114fc0..f137f13305 100644
--- a/compiler/iface/TcIface.hs-boot
+++ b/compiler/iface/TcIface.hs-boot
@@ -1,5 +1,6 @@
 module TcIface where
 
+import GhcPrelude
 import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,
                      IfaceAnnotation, IfaceCompleteMatch )
 import TyCoRep     ( TyThing )
@@ -7,13 +8,11 @@ import TcRnTypes   ( IfL )
 import InstEnv     ( ClsInst )
 import FamInstEnv  ( FamInst )
 import CoreSyn     ( CoreRule )
-import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo, CompleteMatch )
-import Module      ( Module )
+import HscTypes    ( CompleteMatch )
 import Annotations ( Annotation )
 
 tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo     :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
 tcIfaceInst         :: IfaceClsInst -> IfL ClsInst
 tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]
diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index 6f2acba21d..653b7407da 100644
--- a/compiler/iface/ToIface.hs
+++ b/compiler/iface/ToIface.hs
@@ -8,7 +8,7 @@ module ToIface
     , toIfaceIdBndr
     , toIfaceBndr
     , toIfaceForAllBndr
-    , toIfaceTyVarBinders
+    , toIfaceTyCoVarBinders
     , toIfaceTyVar
       -- * Types
     , toIfaceType, toIfaceTypeX
@@ -22,7 +22,7 @@ module ToIface
     , tidyToIfaceContext
     , tidyToIfaceTcArgs
       -- * Coercions
-    , toIfaceCoercion
+    , toIfaceCoercion, toIfaceCoercionX
       -- * Pattern synonyms
     , patSynToIfaceDecl
       -- * Expressions
@@ -44,6 +44,8 @@ module ToIface
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import IfaceSyn
 import DataCon
 import Id
@@ -72,26 +74,39 @@ import Data.Maybe ( catMaybes )
 
 ----------------
 toIfaceTvBndr :: TyVar -> IfaceTvBndr
-toIfaceTvBndr tyvar   = ( occNameFS (getOccName tyvar)
-                        , toIfaceKind (tyVarKind tyvar)
-                        )
+toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
 
-toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
-toIfaceIdBndr id      = (occNameFS (getOccName id),    toIfaceType (idType id))
+toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
+toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
+                          , toIfaceTypeX fr (tyVarKind tyvar)
+                          )
 
 toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
 toIfaceTvBndrs = map toIfaceTvBndr
 
+toIfaceIdBndr :: Id -> IfaceIdBndr
+toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
+
+toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
+toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar)
+                          , toIfaceTypeX fr (varType covar)
+                          )
+
 toIfaceBndr :: Var -> IfaceBndr
 toIfaceBndr var
   | isId var  = IfaceIdBndr (toIfaceIdBndr var)
   | otherwise = IfaceTvBndr (toIfaceTvBndr var)
 
-toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis
-toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis
+toIfaceBndrX :: VarSet -> Var -> IfaceBndr
+toIfaceBndrX fr var
+  | isId var  = IfaceIdBndr (toIfaceIdBndrX fr var)
+  | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)
+
+toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis
+toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis
 
-toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis]
-toIfaceTyVarBinders = map toIfaceTyVarBinder
+toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]
+toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder
 
 {-
 ************************************************************************
@@ -116,9 +131,14 @@ toIfaceTypeX :: VarSet -> Type -> IfaceType
 toIfaceTypeX fr (TyVarTy tv)   -- See Note [TcTyVars in IfaceType] in IfaceType
   | tv `elemVarSet` fr         = IfaceFreeTyVar tv
   | otherwise                  = IfaceTyVar (toIfaceTyVar tv)
-toIfaceTypeX fr (AppTy t1 t2)  = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
+toIfaceTypeX fr ty@(AppTy {})  =
+  -- Flatten as many argument AppTys as possible, then turn them into an
+  -- IfaceAppArgs list.
+  -- See Note [Suppressing invisible arguments] in IfaceType.
+  let (head, args) = splitAppTys ty
+  in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)
 toIfaceTypeX _  (LitTy n)      = IfaceLitTy (toIfaceTyLit n)
-toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b)
+toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
                                                (toIfaceTypeX (fr `delVarSet` binderVar b) t)
 toIfaceTypeX fr (FunTy t1 t2)
   | isPredTy t1                 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
@@ -137,15 +157,11 @@ toIfaceTypeX fr (TyConApp tc tys)
   , n_tys == 2*arity
   = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
 
-    -- type equalities: see Note [Equality predicates in IfaceType]
-  | tyConName tc == eqTyConName
-  = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True)
-    in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
-
   | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
-  , [k1, k2, _t1, _t2] <- tys
-  = let homogeneous = k1 `eqType` k2
-        info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous)
+  , (k1:k2:_) <- tys
+  = let info = IfaceTyConInfo IsNotPromoted sort
+        sort | k1 `eqType` k2 = IfaceEqualityTyCon
+             | otherwise      = IfaceNormalTyCon
     in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
 
     -- other applications
@@ -161,8 +177,11 @@ toIfaceTyVar = occNameFS . getOccName
 toIfaceCoVar :: CoVar -> FastString
 toIfaceCoVar = occNameFS . getOccName
 
-toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
-toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis
+toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
+toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
+
+toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr
+toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis
 
 ----------------
 toIfaceTyCon :: TyCon -> IfaceTyCon
@@ -216,15 +235,23 @@ toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
 toIfaceCoercionX fr co
   = go co
   where
-    go (Refl r ty)          = IfaceReflCo r (toIfaceType ty)
-    go (CoVarCo cv)         = IfaceCoVarCo  (toIfaceCoVar cv)
+    go_mco MRefl     = IfaceMRefl
+    go_mco (MCo co)  = IfaceMCo $ go co
+
+    go (Refl ty)            = IfaceReflCo (toIfaceTypeX fr ty)
+    go (GRefl r ty mco)     = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
+    go (CoVarCo cv)
+      -- See [TcTyVars in IfaceType] in IfaceType
+      | cv `elemVarSet` fr  = IfaceFreeCoVar cv
+      | otherwise           = IfaceCoVarCo (toIfaceCoVar cv)
+    go (HoleCo h)           = IfaceHoleCo  (coHoleCoVar h)
+
     go (AppCo co1 co2)      = IfaceAppCo  (go co1) (go co2)
     go (SymCo co)           = IfaceSymCo (go co)
     go (TransCo co1 co2)    = IfaceTransCo (go co1) (go co2)
-    go (NthCo d co)         = IfaceNthCo d (go co)
+    go (NthCo _r d co)      = IfaceNthCo d (go co)
     go (LRCo lr co)         = IfaceLRCo lr (go co)
     go (InstCo co arg)      = IfaceInstCo (go co) (go arg)
-    go (CoherenceCo c1 c2)  = IfaceCoherenceCo (go c1) (go c2)
     go (KindCo c)           = IfaceKindCo (go c)
     go (SubCo co)           = IfaceSubCo (go co)
     go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)
@@ -236,10 +263,9 @@ toIfaceCoercionX fr co
       | tc `hasKey` funTyConKey
       , [_,_,_,_] <- cos         = pprPanic "toIfaceCoercion" (ppr co)
       | otherwise                = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
-    go (FunCo r co1 co2)   = IfaceFunCo r (toIfaceCoercion co1)
-                                          (toIfaceCoercion co2)
+    go (FunCo r co1 co2)   = IfaceFunCo r (go co1) (go co2)
 
-    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
+    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)
                                           (toIfaceCoercionX fr' k)
                                           (toIfaceCoercionX fr' co)
                           where
@@ -250,13 +276,18 @@ toIfaceCoercionX fr co
     go_prov (PhantomProv co)    = IfacePhantomProv (go co)
     go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
     go_prov (PluginProv str)    = IfacePluginProv str
-    go_prov (HoleProv h)        = IfaceHoleProv (chUnique h)
 
-toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
+toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
 toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
 
-toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs
--- See Note [Suppressing invisible arguments]
+toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs
+toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args
+
+toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs
+toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args
+
+toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs
+-- See Note [Suppressing invisible arguments] in IfaceType
 -- We produce a result list of args describing visibility
 -- The awkward case is
 --    T :: forall k. * -> k
@@ -264,34 +295,43 @@ toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs
 --    T (forall j. blah) * blib
 -- Is 'blib' visible?  It depends on the visibility flag on j,
 -- so we have to substitute for k.  Annoying!
-toIfaceTcArgsX fr tc ty_args
-  = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
+toIfaceAppArgsX fr kind ty_args
+  = go (mkEmptyTCvSubst in_scope) kind ty_args
   where
     in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
 
-    go _   _                   []     = ITC_Nil
+    go _   _                   []     = IA_Nil
     go env ty                  ts
       | Just ty' <- coreView ty
       = go env ty' ts
-    go env (ForAllTy (TvBndr tv vis) res) (t:ts)
-      | isVisibleArgFlag vis = ITC_Vis   t' ts'
-      | otherwise            = ITC_Invis t' ts'
+    go env (ForAllTy (Bndr tv vis) res) (t:ts)
+      | isVisibleArgFlag vis = IA_Vis   t' ts'
+      | otherwise            = IA_Invis t' ts'
       where
         t'  = toIfaceTypeX fr t
-        ts' = go (extendTvSubst env tv t) res ts
+        ts' = go (extendTCvSubst env tv t) res ts
 
     go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
-      = ITC_Vis (toIfaceTypeX fr t) (go env res ts)
-
-    go env (TyVarTy tv) ts
-      | Just ki <- lookupTyVar env tv = go env ki ts
-    go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
-                         ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded
+      = IA_Vis (toIfaceTypeX fr t) (go env res ts)
+
+    go env ty ts@(t1:ts1)
+      | not (isEmptyTCvSubst env)
+      = go (zapTCvSubst env) (substTy env ty) ts
+        -- See Note [Care with kind instantiation] in Type.hs
+
+      | otherwise
+      = -- There's a kind error in the type we are trying to print
+        -- e.g. kind = k, ty_args = [Int]
+        -- This is probably a compiler bug, so we print a trace and
+        -- carry on as if it were FunTy.  Without the test for
+        -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473)
+        WARN( True, ppr kind $$ ppr ty_args )
+        IA_Vis (toIfaceTypeX fr t1) (go env ty ts1)
 
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
 
-tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
+tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
 tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
 
 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
@@ -323,8 +363,8 @@ patSynToIfaceDecl ps
     (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
     univ_bndrs = patSynUnivTyVarBinders ps
     ex_bndrs   = patSynExTyVarBinders ps
-    (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs
-    (env2, ex_bndrs')   = tidyTyVarBinders env1 ex_bndrs
+    (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs
+    (env2, ex_bndrs')   = tidyTyCoVarBinders env1 ex_bndrs
     to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 {-
@@ -436,8 +476,15 @@ toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
       -- No need to serialise the data constructor;
       -- we can recover it from the type of the dfun
 
-toIfUnfolding _ _
-  = Nothing
+toIfUnfolding _ (OtherCon {}) = Nothing
+  -- The binding site of an Id doesn't have OtherCon, except perhaps
+  -- where we have called zapUnfolding; and that evald'ness info is
+  -- not needed by importing modules
+
+toIfUnfolding _ BootUnfolding = Nothing
+  -- Can't happen; we only have BootUnfolding for imported binders
+
+toIfUnfolding _ NoUnfolding = Nothing
 
 {-
 ************************************************************************
@@ -515,19 +562,22 @@ toIfaceApp (Var v) as
 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
 
 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
+mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
 
 ---------------------
 toIfaceVar :: Id -> IfaceExpr
 toIfaceVar v
-    | Just fcall <- isFCallId_maybe v            = IfaceFCall fcall (toIfaceType (idType v))
-       -- Foreign calls have special syntax
     | isBootUnfolding (idUnfolding v)
-    = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v))))
+    = -- See Note [Inlining and hs-boot files]
+      IfaceApp (IfaceApp (IfaceExt noinlineIdName)
+                         (IfaceType (toIfaceType (idType v))))
                (IfaceExt name) -- don't use mkIfaceApps, or infinite loop
-       -- See Note [Inlining and hs-boot files]
-    | isExternalName name                        = IfaceExt name
-    | otherwise                                  = IfaceLcl (getOccFS name)
+
+    | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
+                                      -- Foreign calls have special syntax
+
+    | isExternalName name             = IfaceExt name
+    | otherwise                       = IfaceLcl (getOccFS name)
   where name = idName v
 
 
diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot
index e2431b82dc..e5f57ff9a3 100644
--- a/compiler/iface/ToIface.hs-boot
+++ b/compiler/iface/ToIface.hs-boot
@@ -2,15 +2,15 @@ module ToIface where
 
 import {-# SOURCE #-} TyCoRep
 import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr
-                               , IfaceCoercion, IfaceTyLit, IfaceTcArgs )
-import Var ( TyVarBinder )
+                               , IfaceCoercion, IfaceTyLit, IfaceAppArgs )
+import Var ( TyCoVarBinder )
 import TyCon ( TyCon )
 import VarSet( VarSet )
 
 -- For TyCoRep
 toIfaceTypeX :: VarSet -> Type -> IfaceType
 toIfaceTyLit :: TyLit -> IfaceTyLit
-toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
+toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
 toIfaceTyCon :: TyCon -> IfaceTyCon
-toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
-toIfaceCoercion :: Coercion -> IfaceCoercion
+toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
+toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 8f38c799c7..a89ee35706 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -4,6 +4,8 @@
 
 module Llvm.AbsSyn where
 
+import GhcPrelude
+
 import Llvm.MetaData
 import Llvm.Types
 
@@ -106,7 +108,7 @@ data LlvmAtomicOp
 -- | Llvm Statements
 data LlvmStatement
   {- |
-    Assign an expression to an variable:
+    Assign an expression to a variable:
       * dest:   Variable to assign to
       * source: Source expression
   -}
@@ -258,7 +260,7 @@ data LlvmExpression
   | ALoad LlvmSyncOrdering SingleThreaded LlvmVar
 
   {- |
-    Navigate in an structure, selecting elements
+    Navigate in a structure, selecting elements
       * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
       * ptr:     Location of the structure
       * indexes: A list of indexes to select the correct value.
@@ -323,8 +325,8 @@ data LlvmExpression
     basic block in a new variable of type tp.
       * tp:         type of the merged variable, must match the types of the
                     predecessor variables.
-      * precessors: A list of variables and the basic block that they originate
-                    from.
+      * predecessors: A list of variables and the basic block that they originate
+                      from.
   -}
   | Phi LlvmType [(LlvmVar,LlvmVar)]
 
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 5fe9e37ddc..97e8086f42 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -2,6 +2,8 @@
 
 module Llvm.MetaData where
 
+import GhcPrelude
+
 import Llvm.Types
 import Outputable
 
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 293999bd1e..b350ab408d 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -25,6 +25,8 @@ module Llvm.PpLlvm (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm.AbsSyn
 import Llvm.MetaData
 import Llvm.Types
@@ -238,7 +240,7 @@ ppLlvmExpression expr
         Malloc     tp amount        -> ppMalloc tp amount
         AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
         CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
-        Phi        tp precessors    -> ppPhi tp precessors
+        Phi        tp predecessors  -> ppPhi tp predecessors
         Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
         MExpr      meta expr        -> ppMetaExpr meta expr
 
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index bf23cd89f7..bc7bbaab1b 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -8,6 +8,8 @@ module Llvm.Types where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Data.Char
 import Data.Int
 import Numeric
@@ -152,6 +154,7 @@ data LlvmStatic
   -- static expressions, could split out but leave
   -- for moment for ease of use. Not many of them.
 
+  | LMTrunc LlvmStatic LlvmType        -- ^ Truncate
   | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion
   | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion
   | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation
@@ -165,6 +168,8 @@ instance Outputable LlvmStatic where
   ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
   ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
   ppr (LMStaticPointer v) = ppr v
+  ppr (LMTrunc v t)
+      = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'
   ppr (LMBitc v t)
       = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
   ppr (LMPtoI v t)
@@ -275,6 +280,7 @@ getStatType (LMStaticStr   _ t) = t
 getStatType (LMStaticArray _ t) = t
 getStatType (LMStaticStruc _ t) = t
 getStatType (LMStaticPointer v) = getVarType v
+getStatType (LMTrunc       _ t) = t
 getStatType (LMBitc        _ t) = t
 getStatType (LMPtoI        _ t) = t
 getStatType (LMAdd         t _) = getStatType t
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 71b9996ceb..3fcf83ab2f 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -7,6 +7,8 @@ module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm
 import LlvmCodeGen.Base
 import LlvmCodeGen.CodeGen
@@ -72,7 +74,7 @@ llvmCodeGen dflags h us cmm_stream
 llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
 llvmCodeGen' cmm_stream
   = do  -- Preamble
-        renderLlvm pprLlvmHeader
+        renderLlvm header
         ghcInternalFunctions
         cmmMetaLlvmPrelude
 
@@ -85,6 +87,15 @@ llvmCodeGen' cmm_stream
 
         -- Postamble
         cmmUsedLlvmGens
+  where
+    header :: SDoc
+    header = sdocWithDynFlags $ \dflags ->
+      let target = LLVM_TARGET
+          layout = case lookup target (llvmTargets dflags) of
+            Just (LlvmTarget dl _ _) -> dl
+            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
+      in     text ("target datalayout = \"" ++ layout ++ "\"")
+         $+$ text ("target triple = \"" ++ target ++ "\"")
 
 llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
 llvmGroupLlvmGens cmm = do
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 424891fe77..6e20da48c1 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -37,6 +37,8 @@ module LlvmCodeGen.Base (
 #include "HsVersions.h"
 #include "ghcautoconf.h"
 
+import GhcPrelude
+
 import Llvm
 import LlvmCodeGen.Regs
 
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index a4f67fa4d2..3a56b33753 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -7,6 +7,8 @@ module LlvmCodeGen.CodeGen ( genLlvmProc ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm
 import LlvmCodeGen.Base
 import LlvmCodeGen.Regs
@@ -36,16 +38,16 @@ import Util
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 
-#if __GLASGOW_HASKELL__ > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
-#endif
 import Data.List ( nub )
 import Data.Maybe ( catMaybes )
 
 type Atomic = Bool
 type LlvmStatements = OrdList LlvmStatement
 
+data Signage = Signed | Unsigned deriving (Eq, Show)
+
 -- -----------------------------------------------------------------------------
 -- | Top-level of the LLVM proc Code generator
 --
@@ -207,7 +209,7 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
     let args_hints' = zip args arg_hints
     argVars <- arg_varsW args_hints' ([], nilOL, [])
     fptr    <- liftExprData $ getFunPtr funTy t
-    argVars' <- castVarsW $ zip argVars argTy
+    argVars' <- castVarsW Signed $ zip argVars argTy
 
     let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
     statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
@@ -217,6 +219,11 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
 -- and return types
 genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
     genCallSimpleCast w t dsts args
+
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+    genCallSimpleCast2 w t dsts args
 genCall t@(PrimTarget (MO_Clz w)) dsts args =
     genCallSimpleCast w t dsts args
 genCall t@(PrimTarget (MO_Ctz w)) dsts args =
@@ -284,7 +291,7 @@ genCall t@(PrimTarget op) [] args
     let args_hints = zip args arg_hints
     argVars       <- arg_varsW args_hints ([], nilOL, [])
     fptr          <- getFunPtrW funTy t
-    argVars' <- castVarsW $ zip argVars argTy
+    argVars' <- castVarsW Signed $ zip argVars argTy
 
     let alignVal = mkIntLit i32 align
         arguments = argVars' ++ (alignVal:isVolVal)
@@ -368,6 +375,9 @@ genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
 genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
     genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
 
+genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
 genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
     genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
 
@@ -480,6 +490,7 @@ genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
     let valid = op `elem`   [ MO_Add2 w
                             , MO_AddIntC w
                             , MO_SubIntC w
+                            , MO_AddWordC w
                             , MO_SubWordC w
                             ]
     MASSERT(valid)
@@ -515,7 +526,7 @@ genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
     -- Process the arguments.
     let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
     (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
-    (argsV2, args2) <- castVars $ zip argsV1 argTy
+    (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
 
     -- Get the function and make the call.
     fname <- cmmPrimOpFunctions op
@@ -555,9 +566,10 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
     let (_, arg_hints) = foreignTargetHints t
     let args_hints = zip args arg_hints
     (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
-    (argsV', stmts4)            <- castVars $ zip argsV [width]
+    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
     (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
-    ([retV'], stmts5)           <- castVars [(retV,dstTy)]
+    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
     let s2                       = Store retV' dstV
 
     let stmts = stmts2 `appOL` stmts4 `snocOL`
@@ -566,6 +578,38 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
 genCallSimpleCast _ _ dsts _ =
     panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
 
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast2 _ _ dsts _ =
+    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
+
 -- | Create a function pointer from a target.
 getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
            -> WriterT LlvmAccum LlvmM LlvmVar
@@ -635,31 +679,32 @@ arg_vars ((e, _):rest) (vars, stmts, tops)
 
 
 -- | Cast a collection of LLVM variables to specific types.
-castVarsW :: [(LlvmVar, LlvmType)]
+castVarsW :: Signage
+          -> [(LlvmVar, LlvmType)]
           -> WriterT LlvmAccum LlvmM [LlvmVar]
-castVarsW vars = do
-    (vars, stmts) <- lift $ castVars vars
+castVarsW signage vars = do
+    (vars, stmts) <- lift $ castVars signage vars
     tell $ LlvmAccum stmts mempty
     return vars
 
 -- | Cast a collection of LLVM variables to specific types.
-castVars :: [(LlvmVar, LlvmType)]
+castVars :: Signage -> [(LlvmVar, LlvmType)]
          -> LlvmM ([LlvmVar], LlvmStatements)
-castVars vars = do
-                done <- mapM (uncurry castVar) vars
+castVars signage vars = do
+                done <- mapM (uncurry (castVar signage)) vars
                 let (vars', stmts) = unzip done
                 return (vars', toOL stmts)
 
 -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
-castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
-castVar v t | getVarType v == t
+castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar signage v t | getVarType v == t
             = return (v, Nop)
 
             | otherwise
             = do dflags <- getDynFlags
                  let op = case (getVarType v, t) of
                       (LMInt n, LMInt m)
-                          -> if n < m then LM_Sext else LM_Trunc
+                          -> if n < m then extend else LM_Trunc
                       (vt, _) | isFloat vt && isFloat t
                           -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
                                 then LM_Fpext else LM_Fptrunc
@@ -673,7 +718,16 @@ castVar v t | getVarType v == t
                       (vt, _) -> panic $ "castVars: Can't cast this type ("
                                   ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
                  doExpr t $ Cast op v t
+    where extend = case signage of
+            Signed      -> LM_Sext
+            Unsigned    -> LM_Zext
+
 
+cmmPrimOpRetValSignage :: CallishMachOp -> Signage
+cmmPrimOpRetValSignage mop = case mop of
+    MO_Pdep _   -> Unsigned
+    MO_Pext _   -> Unsigned
+    _           -> Signed
 
 -- | Decide what C function to use to implement a CallishMachOp
 cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
@@ -704,6 +758,10 @@ cmmPrimOpFunctions mop = do
     MO_F32_Cosh   -> fsLit "coshf"
     MO_F32_Tanh   -> fsLit "tanhf"
 
+    MO_F32_Asinh  -> fsLit "asinhf"
+    MO_F32_Acosh  -> fsLit "acoshf"
+    MO_F32_Atanh  -> fsLit "atanhf"
+
     MO_F64_Exp    -> fsLit "exp"
     MO_F64_Log    -> fsLit "log"
     MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
@@ -722,15 +780,29 @@ cmmPrimOpFunctions mop = do
     MO_F64_Cosh   -> fsLit "cosh"
     MO_F64_Tanh   -> fsLit "tanh"
 
+    MO_F64_Asinh  -> fsLit "asinh"
+    MO_F64_Acosh  -> fsLit "acosh"
+    MO_F64_Atanh  -> fsLit "atanh"
+
     MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1
     MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1
     MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2
+    MO_Memcmp _   -> fsLit $ "memcmp"
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_Clz w)    -> fsLit $ "llvm.ctlz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_Ctz w)    -> fsLit $ "llvm.cttz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
 
+    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'
+                            else fsLit $ "hs_pdep"              ++ w'
+    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'
+                            else fsLit $ "hs_pext"              ++ w'
+
     (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
 
     MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."
@@ -739,6 +811,8 @@ cmmPrimOpFunctions mop = do
                              ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."
                              ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."
                              ++ showSDoc dflags (ppr $ widthToLlvmInt w)
 
@@ -1136,6 +1210,8 @@ genMachOp _ op [x] = case op of
             all0s = LMLitVar $ LMVectorLit (replicate len all0)
         in negateVec vecty all0s LM_MO_FSub
 
+    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
     -- Handle unsupported cases explicitly so we get a warning
     -- of missing case when new MachOps added
     MO_Add _          -> panicOp
@@ -1206,7 +1282,8 @@ genMachOp _ op [x] = case op of
 
         negateVec ty v2 negOp = do
             (vx, stmts1, top) <- exprToVar x
-            ([vx'], stmts2) <- castVars [(vx, ty)]
+            (vxs', stmts2) <- castVars Signed [(vx, ty)]
+            let vx' = singletonPanic "genMachOp: negateVec" vxs'
             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
             return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
 
@@ -1269,7 +1346,8 @@ genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
 genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
     vval <- exprToVarW val
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW [(vval, LMVector l ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
     doExprW ty $ Extract vval' vidx
   where
     ty = widthToLlvmInt w
@@ -1277,7 +1355,8 @@ genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
 genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
     vval <- exprToVarW val
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW [(vval, LMVector l ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
     doExprW ty $ Extract vval' vidx
   where
     ty = widthToLlvmFloat w
@@ -1287,7 +1366,8 @@ genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
     vval <- exprToVarW val
     velt <- exprToVarW elt
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW [(vval, ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
     doExprW ty $ Insert vval' velt vidx
   where
     ty = LMVector l (widthToLlvmInt w)
@@ -1296,7 +1376,8 @@ genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
     vval <- exprToVarW val
     velt <- exprToVarW elt
     vidx <- exprToVarW idx
-    [vval'] <- castVarsW [(vval, ty)]
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
     doExprW ty $ Insert vval' velt vidx
   where
     ty = LMVector l (widthToLlvmFloat w)
@@ -1385,6 +1466,8 @@ genMachOp_slow opt op [x, y] = case op of
 
     MO_VF_Neg {} -> panicOp
 
+    MO_AlignmentCheck {} -> panicOp
+
     where
         binLlvmOp ty binOp = runExprData $ do
             vx <- exprToVarW x
@@ -1406,8 +1489,10 @@ genMachOp_slow opt op [x, y] = case op of
         binCastLlvmOp ty binOp = runExprData $ do
             vx <- exprToVarW x
             vy <- exprToVarW y
-            [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]
-            doExprW ty $ binOp vx' vy'
+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+            case vxy' of
+              [vx',vy'] -> doExprW ty $ binOp vx' vy'
+              _         -> panic "genMachOp_slow: binCastLlvmOp"
 
         -- | Need to use EOption here as Cmm expects word size results from
         -- comparisons while LLVM return i1. Need to extend to llvmWord type
@@ -1463,8 +1548,8 @@ genMachOp_slow opt op [x, y] = case op of
         panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
                        ++ "with two arguments! (" ++ show op ++ ")"
 
--- More then two expression, invalid!
-genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
+-- More than two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
 
 
 -- | Handle CmmLoad expression.
@@ -1650,7 +1735,7 @@ genLit opt (CmmLabelOff label off) = do
     (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
     return (v1, stmts `snocOL` s1, stat)
 
-genLit opt (CmmLabelDiffOff l1 l2 off) = do
+genLit opt (CmmLabelDiffOff l1 l2 off w) = do
     dflags <- getDynFlags
     (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
     (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
@@ -1659,13 +1744,17 @@ genLit opt (CmmLabelDiffOff l1 l2 off) = do
     let ty2 = getVarType vl2
     if (isInt ty1) && (isInt ty2)
        && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
-
        then do
             (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
             (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
-            return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
-                        stat1 ++ stat2)
-
+            let ty = widthToLlvmInt w
+            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
+            if w /= wordWidth dflags
+              then do
+                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
+                return (v3, stmts `snocOL` s3, stat1 ++ stat2)
+              else
+                return (v2, stmts, stat1 ++ stat2)
         else
             panic "genLit: CmmLabelDiffOff encountered with different label ty!"
 
@@ -1832,16 +1921,13 @@ getTBAARegMeta = getTBAAMeta . getTBAA
 -- | A more convenient way of accumulating LLVM statements and declarations.
 data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
 
-#if __GLASGOW_HASKELL__ > 710
 instance Semigroup LlvmAccum where
   LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
         LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
-#endif
 
 instance Monoid LlvmAccum where
     mempty = LlvmAccum nilOL []
-    LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =
-        LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB)
+    mappend = (Semigroup.<>)
 
 liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
 liftExprData action = do
@@ -1876,3 +1962,8 @@ getCmmRegW = lift . getCmmReg
 
 genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
 genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 39abbd1ac0..36d51e9e18 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -9,6 +9,8 @@ module LlvmCodeGen.Data (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm
 import LlvmCodeGen.Base
 
@@ -146,12 +148,14 @@ genStaticLit (CmmLabelOff label off) = do
     let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
     return $ LMAdd var offset
 
-genStaticLit (CmmLabelDiffOff l1 l2 off) = do
+genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
     dflags <- getDynFlags
     var1 <- genStaticLit (CmmLabel l1)
     var2 <- genStaticLit (CmmLabel l2)
-    let var = LMSub var1 var2
-        offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+    let var
+          | w == wordWidth dflags = LMSub var1 var2
+          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
+        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
     return $ LMAdd var offset
 
 genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 8614084f0c..2a8340bcf9 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -4,18 +4,19 @@
 -- | Pretty print helpers for the LLVM Code generator.
 --
 module LlvmCodeGen.Ppr (
-        pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
+        pprLlvmCmmDecl, pprLlvmData, infoSection
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm
 import LlvmCodeGen.Base
 import LlvmCodeGen.Data
 
 import CLabel
 import Cmm
-import Platform
 
 import FastString
 import Outputable
@@ -25,66 +26,6 @@ import Unique
 -- * Top level
 --
 
--- | Header code for LLVM modules
-pprLlvmHeader :: SDoc
-pprLlvmHeader = moduleLayout
-
-
--- | LLVM module layout description for the host target
-moduleLayout :: SDoc
-moduleLayout = sdocWithPlatform $ \platform ->
-    case platform of
-    Platform { platformArch = ArchX86, platformOS = OSDarwin } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
-        $+$ text "target triple = \"i386-apple-darwin9.8\""
-    Platform { platformArch = ArchX86, platformOS = OSMinGW32 } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
-        $+$ text "target triple = \"i686-pc-win32\""
-    Platform { platformArch = ArchX86, platformOS = OSLinux } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
-        $+$ text "target triple = \"i386-pc-linux-gnu\""
-    Platform { platformArch = ArchX86_64, platformOS = OSDarwin } ->
-        text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
-        $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
-    Platform { platformArch = ArchX86_64, platformOS = OSLinux } ->
-        text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
-        $+$ text "target triple = \"x86_64-linux-gnu\""
-    Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
-        $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""
-    Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
-        $+$ text "target triple = \"arm-unknown-linux-androideabi\""
-    Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } ->
-        text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
-        $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\""
-    Platform { platformArch = ArchARM {}, platformOS = OSiOS } ->
-        text "target datalayout = \"e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32\""
-        $+$ text "target triple = \"thumbv7-apple-ios7.0.0\""
-    Platform { platformArch = ArchARM64, platformOS = OSiOS } ->
-        text "target datalayout = \"e-m:o-i64:64-i128:128-n32:64-S128\""
-        $+$ text "target triple = \"arm64-apple-ios7.0.0\""
-    Platform { platformArch = ArchX86, platformOS = OSiOS } ->
-        text "target datalayout = \"e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128\""
-        $+$ text "target triple = \"i386-apple-ios7.0.0\""
-    Platform { platformArch = ArchX86_64, platformOS = OSiOS } ->
-        text "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\""
-        $+$ text "target triple = \"x86_64-apple-ios7.0.0\""
-    Platform { platformArch = ArchARM64, platformOS = OSLinux } ->
-        text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\""
-        $+$ text "target triple = \"aarch64-unknown-linux-gnu\""
-    _ ->
-        if platformIsCrossCompiling platform
-            then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info."
-            else empty
-        -- If you see the above panic, GHC is missing the required target datalayout
-        -- and triple information. You can obtain this info by compiling a simple
-        -- 'hello world' C program with the clang C compiler eg:
-        --     clang -S hello.c -emit-llvm -o -
-        -- and the first two lines of hello.ll should provide the 'target datalayout'
-        -- and 'target triple' lines required.
-
-
 -- | Pretty print LLVM data code
 pprLlvmData :: LlvmData -> SDoc
 pprLlvmData (globals, types) =
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index e09ab8026c..8cdf3c6869 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -11,6 +11,8 @@ module LlvmCodeGen.Regs (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Llvm
 
 import CmmExpr
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index eed13ba203..fe03cf21e9 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -11,6 +11,8 @@
 
 module LlvmMangler ( llvmFixupAsm ) where
 
+import GhcPrelude
+
 import DynFlags ( DynFlags, targetPlatform )
 import Platform ( platformArch, Arch(..) )
 import ErrUtils ( withTiming )
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs
index 052b0615e7..f6d5a1cb12 100644
--- a/compiler/main/Annotations.hs
+++ b/compiler/main/Annotations.hs
@@ -17,6 +17,8 @@ module Annotations (
         deserializeAnns
     ) where
 
+import GhcPrelude
+
 import Binary
 import Module           ( Module )
 import Name
diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs
new file mode 100644
index 0000000000..814b71e248
--- /dev/null
+++ b/compiler/main/Ar.hs
@@ -0,0 +1,269 @@
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
+{- Note: [The need for Ar.hs]
+Building `-staticlib` required the presence of libtool, and was a such
+restricted to mach-o only. As libtool on macOS and gnu libtool are very
+different, there was no simple portable way to support this.
+
+libtool for static archives does essentially: concatinate the input archives,
+add the input objects, and create a symbol index. Using `ar` for this task
+fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
+features across platforms (e.g. index prefixed retrieval of objects with
+the same name.)
+
+As Archives are rather simple structurally, we can just build the archives
+with Haskell directly and use ranlib on the final result to get the symbol
+index. This should allow us to work around with the differences/abailability
+of libtool across differet platforms.
+-}
+module Ar
+  (ArchiveEntry(..)
+  ,Archive(..)
+  ,afilter
+
+  ,parseAr
+
+  ,loadAr
+  ,loadObj
+  ,writeBSDAr
+  ,writeGNUAr
+
+  ,isBSDSymdef
+  ,isGNUSymdef
+  )
+   where
+
+import GhcPrelude
+
+import Data.Semigroup (Semigroup)
+import Data.List (mapAccumL, isPrefixOf)
+import Data.Monoid ((<>))
+import Data.Binary.Get
+import Data.Binary.Put
+import Control.Monad
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Files as POSIX
+#endif
+import System.FilePath (takeFileName)
+
+data ArchiveEntry = ArchiveEntry
+    { filename :: String       -- ^ File name.
+    , filetime :: Int          -- ^ File modification time.
+    , fileown  :: Int          -- ^ File owner.
+    , filegrp  :: Int          -- ^ File group.
+    , filemode :: Int          -- ^ File mode.
+    , filesize :: Int          -- ^ File size.
+    , filedata :: B.ByteString -- ^ File bytes.
+    } deriving (Eq, Show)
+
+newtype Archive = Archive [ArchiveEntry]
+        deriving (Eq, Show, Semigroup, Monoid)
+
+afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
+afilter f (Archive xs) = Archive (filter f xs)
+
+isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
+isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
+isGNUSymdef a = "/" == (filename a)
+
+-- | Archives have numeric values padded with '\x20' to the right.
+getPaddedInt :: B.ByteString -> Int
+getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
+
+putPaddedInt :: Int -> Int -> Put
+putPaddedInt padding i = putPaddedString '\x20' padding (show i)
+
+putPaddedString :: Char -> Int -> String -> Put
+putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
+
+getBSDArchEntries :: Get [ArchiveEntry]
+getBSDArchEntries = do
+    empty <- isEmpty
+    if empty then
+        return []
+     else do
+        name    <- getByteString 16
+        when ('/' `C.elem` name && C.take 3 name /= "#1/") $
+          fail "Looks like GNU Archive"
+        time    <- getPaddedInt <$> getByteString 12
+        own     <- getPaddedInt <$> getByteString 6
+        grp     <- getPaddedInt <$> getByteString 6
+        mode    <- getPaddedInt <$> getByteString 8
+        st_size <- getPaddedInt <$> getByteString 10
+        end     <- getByteString 2
+        when (end /= "\x60\x0a") $
+          fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+                C.unpack name)
+        off1    <- liftM fromIntegral bytesRead :: Get Int
+        -- BSD stores extended filenames, by writing #1/<length> into the
+        -- name field, the first @length@ bytes then represent the file name
+        -- thus the payload size is filesize + file name length.
+        name    <- if C.unpack (C.take 3 name) == "#1/" then
+                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
+                    else
+                        return $ C.unpack $ C.takeWhile (/= ' ') name
+        off2    <- liftM fromIntegral bytesRead :: Get Int
+        file    <- getByteString (st_size - (off2 - off1))
+        -- data sections are two byte aligned (see Trac #15396)
+        when (odd st_size) $
+          void (getByteString 1)
+
+        rest    <- getBSDArchEntries
+        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
+
+-- | GNU Archives feature a special '//' entry that contains the
+-- extended names. Those are referred to as /<num>, where num is the
+-- offset into the '//' entry.
+-- In addition, filenames are terminated with '/' in the archive.
+getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
+getGNUArchEntries extInfo = do
+  empty <- isEmpty
+  if empty
+    then return []
+    else
+    do
+      name    <- getByteString 16
+      time    <- getPaddedInt <$> getByteString 12
+      own     <- getPaddedInt <$> getByteString 6
+      grp     <- getPaddedInt <$> getByteString 6
+      mode    <- getPaddedInt <$> getByteString 8
+      st_size <- getPaddedInt <$> getByteString 10
+      end     <- getByteString 2
+      when (end /= "\x60\x0a") $
+        fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+              C.unpack name)
+      file <- getByteString st_size
+      -- data sections are two byte aligned (see Trac #15396)
+      when (odd st_size) $
+        void (getByteString 1)
+      name <- return . C.unpack $
+        if C.unpack (C.take 1 name) == "/"
+        then case C.takeWhile (/= ' ') name of
+               name@"/"  -> name               -- symbol table
+               name@"//" -> name               -- extendedn file names table
+               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
+        else C.takeWhile (/= '/') name
+      case name of
+        "/"  -> getGNUArchEntries extInfo
+        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
+        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
+
+  where
+   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
+   getExtName Nothing _ = error "Invalid extended filename reference."
+   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
+
+-- | put an Archive Entry. This assumes that the entries
+-- have been preprocessed to account for the extenden file name
+-- table section "//" e.g. for GNU Archives. Or that the names
+-- have been move into the payload for BSD Archives.
+putArchEntry :: ArchiveEntry -> PutM ()
+putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
+  putPaddedString ' '  16 name
+  putPaddedInt         12 time
+  putPaddedInt          6 own
+  putPaddedInt          6 grp
+  putPaddedInt          8 mode
+  putPaddedInt         10 (st_size + pad)
+  putByteString           "\x60\x0a"
+  putByteString           file
+  when (pad == 1) $
+    putWord8              0x0a
+  where
+    pad         = st_size `mod` 2
+
+getArchMagic :: Get ()
+getArchMagic = do
+  magic <- liftM C.unpack $ getByteString 8
+  if magic /= "!<arch>\n"
+    then fail $ "Invalid magic number " ++ show magic
+    else return ()
+
+putArchMagic :: Put
+putArchMagic = putByteString $ C.pack "!<arch>\n"
+
+getArch :: Get Archive
+getArch = Archive <$> do
+  getArchMagic
+  getBSDArchEntries <|> getGNUArchEntries Nothing
+
+putBSDArch :: Archive -> PutM ()
+putBSDArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    padStr pad size str = take size $ str <> repeat pad
+    nameSize name = case length name `divMod` 4 of
+      (n, 0) -> 4 * n
+      (n, _) -> 4 * (n + 1)
+    needExt name = length name > 16 || ' ' `elem` name
+    processEntry :: ArchiveEntry -> ArchiveEntry
+    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
+      | needExt name = archive { filename = "#1/" <> show sz
+                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
+                               , filesize = st_size + sz }
+      | otherwise    = archive
+
+      where sz = nameSize name
+
+    processEntries = map processEntry
+
+putGNUArch :: Archive -> PutM ()
+putGNUArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
+    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
+      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
+                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
+                           , archive { filename = "/" <> show (filesize extInfo) } )
+      | otherwise        = ( extInfo, archive { filename = name <> "/" } )
+
+    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
+    processEntries =
+      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
+
+parseAr :: B.ByteString -> Archive
+parseAr = runGet getArch . L.fromChunks . pure
+
+writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
+writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
+writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
+
+loadAr :: FilePath -> IO Archive
+loadAr fp = parseAr <$> B.readFile fp
+
+loadObj :: FilePath -> IO ArchiveEntry
+loadObj fp = do
+  payload <- B.readFile fp
+  (modt, own, grp, mode) <- fileInfo fp
+  return $ ArchiveEntry
+    (takeFileName fp) modt own grp mode
+    (B.length payload) payload
+
+-- | Take a filePath and return (mod time, own, grp, mode in decimal)
+fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
+#if defined(mingw32_HOST_OS)
+-- on windows mod time, owner group and mode are zero.
+fileInfo _ = pure (0,0,0,0)
+#else
+fileInfo fp = go <$> POSIX.getFileStatus fp
+  where go status = ( fromEnum $ POSIX.modificationTime status
+                    , fromIntegral $ POSIX.fileOwner status
+                    , fromIntegral $ POSIX.fileGroup status
+                    , oct2dec . fromIntegral $ POSIX.fileMode status
+                    )
+
+oct2dec :: Int -> Int
+oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
+  where dec _ 0 = []
+        dec b i = let (rest, last) = i `quotRem` b
+                  in last:dec b rest
+
+#endif
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index e6ecd17bdf..cb30b6fe6c 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -25,6 +25,8 @@ module CmdLineParser
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Util
 import Outputable
 import Panic
@@ -77,8 +79,6 @@ data OptKind m                             -- Suppose the flag is -f
     | FloatSuffix (Float -> EwM m ())      -- -f or -f=n; pass n to fn
     | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn
     | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn
-    | PrefixPred    (String -> Bool) (String -> EwM m ())
-    | AnySuffixPred (String -> Bool) (String -> EwM m ())
 
 
 --------------------------------------------------------
@@ -240,11 +240,9 @@ processOneArg opt_kind rest arg args
                         []               -> missingArgErr dash_arg
                         (L _ arg1:args1) -> Right (f arg1, args1)
 
+        -- See Trac #12625
         Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
-                 | otherwise          -> unknownFlagErr dash_arg
-
-        PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
-                       | otherwise          -> unknownFlagErr dash_arg
+                 | otherwise          -> missingArgErr  dash_arg
 
         PassFlag f  | notNull rest -> unknownFlagErr dash_arg
                     | otherwise    -> Right (f dash_arg, args)
@@ -261,7 +259,6 @@ processOneArg opt_kind rest arg args
 
         OptPrefix f       -> Right (f rest_no_eq, args)
         AnySuffix f       -> Right (f dash_arg, args)
-        AnySuffixPred _ f -> Right (f dash_arg, args)
 
 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
 findArg spec arg =
@@ -279,15 +276,14 @@ arg_ok :: OptKind t -> [Char] -> String -> Bool
 arg_ok (NoArg           _)  rest _   = null rest
 arg_ok (HasArg          _)  _    _   = True
 arg_ok (SepArg          _)  rest _   = null rest
-arg_ok (Prefix          _)  rest _   = notNull rest
-arg_ok (PrefixPred p    _)  rest _   = notNull rest && p (dropEq rest)
+arg_ok (Prefix          _)  _    _   = True -- Missing argument checked for in processOneArg t
+                                            -- to improve error message (Trac #12625)
 arg_ok (OptIntSuffix    _)  _    _   = True
 arg_ok (IntSuffix       _)  _    _   = True
 arg_ok (FloatSuffix     _)  _    _   = True
 arg_ok (OptPrefix       _)  _    _   = True
 arg_ok (PassFlag        _)  rest _   = null rest
 arg_ok (AnySuffix       _)  _    _   = True
-arg_ok (AnySuffixPred p _)  _    arg = p arg
 
 -- | Parse an Int
 --
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 34cada3ff9..478de594ac 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -10,6 +10,8 @@ module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import AsmCodeGen ( nativeCodeGen )
 import LlvmCodeGen ( llvmCodeGen )
 
@@ -36,7 +38,6 @@ import Control.Exception
 import System.Directory
 import System.FilePath
 import System.IO
-import Control.Monad (forM)
 
 {-
 ************************************************************************
@@ -51,7 +52,7 @@ codeOutput :: DynFlags
            -> FilePath
            -> ModLocation
            -> ForeignStubs
-           -> [(ForeignSrcLang, String)]
+           -> [(ForeignSrcLang, FilePath)]
            -- ^ additional files to be compiled with with the C compiler
            -> [InstalledUnitId]
            -> Stream IO RawCmmGroup ()                       -- Compiled C--
@@ -59,7 +60,7 @@ codeOutput :: DynFlags
                   (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
                   [(ForeignSrcLang, FilePath)]{-foreign_fps-})
 
-codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
+codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
   cmm_stream
   =
     do  {
@@ -87,10 +88,6 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
                 }
 
         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
-        ; foreign_fps <- forM foreign_files $ \(lang, file_contents) -> do
-            { fp <- outputForeignFile dflags lang file_contents;
-            ; return (lang, fp);
-            }
         ; case hscTarget dflags of {
              HscAsm         -> outputAsm dflags this_mod location filenm
                                          linted_cmm_stream;
@@ -268,14 +265,3 @@ outputForeignStubs_help fname doc_str header footer
    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
         return True
 
-outputForeignFile :: DynFlags -> ForeignSrcLang -> String -> IO FilePath
-outputForeignFile dflags lang file_contents
- = do
-   extension <- case lang of
-     LangC -> return "c"
-     LangCxx -> return "cpp"
-     LangObjc -> return "m"
-     LangObjcxx -> return "mm"
-   fp <- newTempName dflags TFL_CurrentModule extension
-   writeFile fp file_contents
-   return fp
diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs
index 3dafbac996..7eda130917 100644
--- a/compiler/main/Constants.hs
+++ b/compiler/main/Constants.hs
@@ -6,6 +6,8 @@
 
 module Constants (module Constants) where
 
+import GhcPrelude
+
 import Config
 
 hiVersion :: Integer
@@ -36,5 +38,9 @@ mAX_SOLVER_ITERATIONS = 4
 wORD64_SIZE :: Int
 wORD64_SIZE = 8
 
+-- Size of float in bytes.
+fLOAT_SIZE :: Int
+fLOAT_SIZE = 4
+
 tARGET_MAX_CHAR :: Int
 tARGET_MAX_CHAR = 0x10ffff
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 8cf14c57e5..741104596a 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -14,12 +14,13 @@ module DriverMkDepend (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import qualified GHC
 import GhcMonad
 import DynFlags
 import Util
 import HscTypes
-import FileCleanup      ( newTempName )
 import qualified SysTools
 import Module
 import Digraph          ( SCC(..) )
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index a59c452788..57455a5463 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -40,6 +40,8 @@ module DriverPhases (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} DynFlags
 import Outputable
 import Platform
@@ -287,8 +289,8 @@ phaseInputExt LlvmOpt             = "ll"
 phaseInputExt LlvmLlc             = "bc"
 phaseInputExt LlvmMangle          = "lm_s"
 phaseInputExt SplitAs             = "split_s"
-phaseInputExt CmmCpp              = "cmm"
-phaseInputExt Cmm                 = "cmmcpp"
+phaseInputExt CmmCpp              = "cmmcpp"
+phaseInputExt Cmm                 = "cmm"
 phaseInputExt MergeForeign        = "o"
 phaseInputExt StopLn              = "o"
 
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 3fc35e5992..a9e486c94a 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
 {-# OPTIONS_GHC -fno-cse #-}
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
@@ -28,20 +28,20 @@ module DriverPipeline (
    phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
    hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
    runPhase, exeFileName,
-   mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
    maybeCreateManifest,
    linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
   ) where
 
 #include "HsVersions.h"
 
-import AsmUtils
+import GhcPrelude
+
 import PipelineMonad
 import Packages
 import HeaderInfo
 import DriverPhases
 import SysTools
-import Elf
+import SysTools.ExtraObj
 import HscMain
 import Finder
 import HscTypes hiding ( Hsc )
@@ -63,15 +63,17 @@ import TcRnTypes
 import Hooks
 import qualified GHC.LanguageExtensions as LangExt
 import FileCleanup
+import Ar
 
 import Exception
 import System.Directory
 import System.FilePath
 import System.IO
 import Control.Monad
-import Data.List        ( isSuffixOf )
+import Data.List        ( isInfixOf, isSuffixOf, intercalate )
 import Data.Maybe
 import Data.Version
+import Data.Either      ( partitionEithers )
 
 -- ---------------------------------------------------------------------------
 -- Pre-process
@@ -261,11 +263,10 @@ compileOne' m_tc_result mHscMessage
        -- imports a _stub.h file that we created here.
        current_dir = takeDirectory basename
        old_paths   = includePaths dflags1
-       prevailing_dflags = hsc_dflags hsc_env0
+       !prevailing_dflags = hsc_dflags hsc_env0
        dflags =
-          dflags1 { includePaths = current_dir : old_paths
-                  , log_action = log_action prevailing_dflags
-                  , log_finaliser = log_finaliser prevailing_dflags }
+          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
+                  , log_action = log_action prevailing_dflags }
                   -- use the prevailing log_action / log_finaliser,
                   -- not the one cached in the summary.  This is so
                   -- that we can change the log_action without having
@@ -300,12 +301,14 @@ compileOne' m_tc_result mHscMessage
 -- useful to implement facilities such as inline-c.
 
 compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
+compileForeign _ RawObject object_file = return object_file
 compileForeign hsc_env lang stub_c = do
         let phase = case lang of
               LangC -> Cc
               LangCxx -> Ccxx
               LangObjc -> Cobjc
               LangObjcxx -> Cobjcxx
+              RawObject -> panic "compileForeign: should be unreachable"
         (_, stub_o) <- runPipeline StopLn hsc_env
                        (stub_c, Just (RealPhase phase))
                        Nothing (Temporary TFL_GhcSession)
@@ -423,7 +426,7 @@ link' dflags batch_attempt_linking hpt
         -- Don't showPass in Batch mode; doLink will do that for us.
         let link = case ghcLink dflags of
                 LinkBinary    -> linkBinary
-                LinkStaticLib -> linkStaticLibCheck
+                LinkStaticLib -> linkStaticLib
                 LinkDynLib    -> linkDynLibCheck
                 other         -> panicBadLink other
         link dflags obj_files pkg_deps
@@ -452,7 +455,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
         -- first check object files and extra_ld_inputs
         let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
         e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
-        let (errs,extra_times) = splitEithers e_extra_times
+        let (errs,extra_times) = partitionEithers e_extra_times
         let obj_times =  map linkableTime linkables ++ extra_times
         if not (null errs) || any (t <) obj_times
             then return True
@@ -468,55 +471,16 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
         if any isNothing pkg_libfiles then return True else do
         e_lib_times <- mapM (tryIO . getModificationUTCTime)
                           (catMaybes pkg_libfiles)
-        let (lib_errs,lib_times) = splitEithers e_lib_times
+        let (lib_errs,lib_times) = partitionEithers e_lib_times
         if not (null lib_errs) || any (t <) lib_times
            then return True
            else checkLinkInfo dflags pkg_deps exe_file
 
--- Returns 'False' if it was, and we can avoid linking, because the
--- previous binary was linked with "the same options".
-checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
-checkLinkInfo dflags pkg_deps exe_file
- | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
- -- ToDo: Windows and OS X do not use the ELF binary format, so
- -- readelf does not work there.  We need to find another way to do
- -- this.
- = return False -- conservatively we should return True, but not
-                -- linking in this case was the behaviour for a long
-                -- time so we leave it as-is.
- | otherwise
- = do
-   link_info <- getLinkInfo dflags pkg_deps
-   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
-   m_exe_link_info <- readElfNoteAsString dflags exe_file
-                          ghcLinkInfoSectionName ghcLinkInfoNoteName
-   let sameLinkInfo = (Just link_info == m_exe_link_info)
-   debugTraceMsg dflags 3 $ case m_exe_link_info of
-     Nothing -> text "Exe link info: Not found"
-     Just s
-       | sameLinkInfo -> text ("Exe link info is the same")
-       | otherwise    -> text ("Exe link info is different: " ++ s)
-   return (not sameLinkInfo)
-
-platformSupportsSavingLinkOpts :: OS -> Bool
-platformSupportsSavingLinkOpts os
-  | os == OSSolaris2 = False -- see #5382
-  | otherwise        = osElfTarget os
-
--- See Note [LinkInfo section]
-ghcLinkInfoSectionName :: String
-ghcLinkInfoSectionName = ".debug-ghc-link-info"
-   -- if we use the ".debug" prefix, then strip will strip it by default
-
--- Identifier for the note (see Note [LinkInfo section])
-ghcLinkInfoNoteName :: String
-ghcLinkInfoNoteName = "GHC link info"
-
 findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
 findHSLib dflags dirs lib = do
   let batch_lib_file = if WayDyn `notElem` ways dflags
-                       then "lib" ++ lib <.> "a"
-                       else mkSOName (targetPlatform dflags) lib
+                      then "lib" ++ lib <.> "a"
+                      else mkSOName (targetPlatform dflags) lib
   found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
   case found of
     [] -> return Nothing
@@ -574,7 +538,7 @@ doLink dflags stop_phase o_files
   = case ghcLink dflags of
         NoLink        -> return ()
         LinkBinary    -> linkBinary         dflags o_files []
-        LinkStaticLib -> linkStaticLibCheck dflags o_files []
+        LinkStaticLib -> linkStaticLib      dflags o_files []
         LinkDynLib    -> linkDynLibCheck    dflags o_files []
         other         -> panicBadLink other
 
@@ -798,6 +762,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
           odir       = objectDir dflags
           osuf       = objectSuf dflags
           keep_hc    = gopt Opt_KeepHcFiles dflags
+          keep_hscpp = gopt Opt_KeepHscppFiles dflags
           keep_s     = gopt Opt_KeepSFiles dflags
           keep_bc    = gopt Opt_KeepLlvmFiles dflags
 
@@ -814,6 +779,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
                        As _    | keep_s     -> True
                        LlvmOpt | keep_bc    -> True
                        HCc     | keep_hc    -> True
+                       HsPp _  | keep_hscpp -> True   -- See Trac #10869
                        _other               -> False
 
           suffix = myPhaseInputExt next_phase
@@ -830,6 +796,66 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
              | Just d <- odir = d </> persistent
              | otherwise      = persistent
 
+
+-- | The fast LLVM Pipeline skips the mangler and assembler,
+-- emitting object code directly from llc.
+--
+-- slow: opt -> llc -> .s -> mangler -> as -> .o
+-- fast: opt -> llc -> .o
+--
+-- hidden flag: -ffast-llvm
+--
+-- if keep-s-files is specified, we need to go through
+-- the slow pipeline (Kavon Farvardin requested this).
+fastLlvmPipeline :: DynFlags -> Bool
+fastLlvmPipeline dflags
+  = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
+
+-- | LLVM Options. These are flags to be passed to opt and llc, to ensure
+-- consistency we list them in pairs, so that they form groups.
+llvmOptions :: DynFlags
+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
+llvmOptions dflags =
+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
+    ++ [("-relocation-model=" ++ rmodel
+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
+    ++ [("-stack-alignment=" ++ (show align)
+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
+    ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
+
+    -- Additional llc flags
+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
+
+  where target = LLVM_TARGET
+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
+
+        -- Relocation models
+        rmodel | gopt Opt_PIC dflags        = "pic"
+               | positionIndependent dflags = "pic"
+               | WayDyn `elem` ways dflags  = "dynamic-no-pic"
+               | otherwise                  = "static"
+
+        align :: Int
+        align = case platformArch (targetPlatform dflags) of
+                  ArchX86_64 | isAvxEnabled dflags -> 32
+                  _                                -> 0
+
+        attrs :: String
+        attrs = intercalate "," $ mattr
+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]
+              ++ ["+sse2"    | isSse2Enabled dflags     ]
+              ++ ["+sse"     | isSseEnabled dflags      ]
+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]
+              ++ ["+avx2"    | isAvx2Enabled dflags     ]
+              ++ ["+avx"     | isAvxEnabled dflags      ]
+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
+              ++ ["+avx512er"| isAvx512erEnabled dflags ]
+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
+              ++ ["+bmi"     | isBmiEnabled dflags      ]
+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]
+
 -- -----------------------------------------------------------------------------
 -- | Each phase in the pipeline returns the next phase to execute, and the
 -- name of the file in which the output was placed.
@@ -968,8 +994,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
   -- the .hs files resides) to the include path, since this is
   -- what gcc does, and it's probably what you want.
         let current_dir = takeDirectory basename
+            new_includes = addQuoteInclude paths [current_dir]
             paths = includePaths dflags0
-            dflags = dflags0 { includePaths = current_dir : paths }
+            dflags = dflags0 { includePaths = new_includes }
 
         setDynFlags dflags
 
@@ -1136,8 +1163,11 @@ runPhase (RealPhase cc_phase) input_fn dflags
         -- files; this is the Value Add(TM) that using ghc instead of
         -- gcc gives you :)
         pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
-        let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) []
-                              (cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+              (includePathsQuote cmdline_include_paths)
+        let include_paths = include_paths_quote ++ include_paths_global
 
         let gcc_extra_viac_flags = extraGccViaCFlags dflags
         let pic_c_flags = picCCOpts dflags
@@ -1300,10 +1330,13 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
         liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
 
         ccInfo <- liftIO $ getCompilerInfo dflags
+        let global_includes = [ SysTools.Option ("-I" ++ p)
+                              | p <- includePathsGlobal cmdline_include_paths ]
+        let local_includes = [ SysTools.Option ("-iquote" ++ p)
+                             | p <- includePathsQuote cmdline_include_paths ]
         let runAssembler inputFilename outputFilename
                 = liftIO $ as_prog dflags
-                       ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
-
+                       (local_includes ++ global_includes
                        -- See Note [-fPIC for assembler]
                        ++ map SysTools.Option pic_c_flags
 
@@ -1427,121 +1460,117 @@ runPhase (RealPhase SplitAs) _input_fn dflags
 
 -----------------------------------------------------------------------------
 -- LlvmOpt phase
-
 runPhase (RealPhase LlvmOpt) input_fn dflags
   = do
-    let opt_lvl  = max 0 (min 2 $ optLevel dflags)
-        -- don't specify anything if user has specified commands. We do this
-        -- for opt but not llc since opt is very specifically for optimisation
-        -- passes only, so if the user is passing us extra options we assume
-        -- they know what they are doing and don't get in the way.
-        optFlag  = if null (getOpts dflags opt_lo)
-                       then map SysTools.Option $ words (llvmOpts !! opt_lvl)
-                       else []
-        tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
-             | otherwise                = "--enable-tbaa=false"
-
-
     output_fn <- phaseOutputFilename LlvmLlc
 
     liftIO $ SysTools.runLlvmOpt dflags
-               ([ SysTools.FileOption "" input_fn,
-                    SysTools.Option "-o",
-                    SysTools.FileOption "" output_fn]
-                ++ optFlag
-                ++ [SysTools.Option tbaa])
+               (   optFlag
+                ++ defaultOptions ++
+                [ SysTools.FileOption "" input_fn
+                , SysTools.Option "-o"
+                , SysTools.FileOption "" output_fn]
+                )
 
     return (RealPhase LlvmLlc, output_fn)
   where
         -- we always (unless -optlo specified) run Opt since we rely on it to
         -- fix up some pretty big deficiencies in the code we generate
-        llvmOpts =  [ "-mem2reg -globalopt"
-                    , "-O1 -globalopt"
-                    , "-O2"
-                    ]
+        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]
+        llvmOpts = case lookup optIdx $ llvmPasses dflags of
+                    Just passes -> passes
+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
+                                      ++ "is missing passes for level "
+                                      ++ show optIdx)
+
+        -- don't specify anything if user has specified commands. We do this
+        -- for opt but not llc since opt is very specifically for optimisation
+        -- passes only, so if the user is passing us extra options we assume
+        -- they know what they are doing and don't get in the way.
+        optFlag = if null (getOpts dflags opt_lo)
+                  then map SysTools.Option $ words llvmOpts
+                  else []
+
+        defaultOptions = map SysTools.Option . concat . fmap words . fst
+                       $ unzip (llvmOptions dflags)
 
 -----------------------------------------------------------------------------
 -- LlvmLlc phase
 
 runPhase (RealPhase LlvmLlc) input_fn dflags
   = do
-    let opt_lvl = max 0 (min 2 $ optLevel dflags)
-        -- iOS requires external references to be loaded indirectly from the
-        -- DATA segment or dyld traps at runtime writing into TEXT: see #7722
-        rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic"
-               | gopt Opt_PIC dflags                         = "pic"
-               | WayDyn `elem` ways dflags                   = "dynamic-no-pic"
-               | otherwise                                   = "static"
-        tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
-             | otherwise                = "--enable-tbaa=false"
-
-    -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
-    let next_phase = case gopt Opt_NoLlvmMangler dflags of
-                         False                            -> LlvmMangle
-                         True | gopt Opt_SplitObjs dflags -> Splitter
-                         True                             -> As False
+    next_phase <- if fastLlvmPipeline dflags
+                  then maybeMergeForeign
+                  -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
+                  else case gopt Opt_NoLlvmMangler dflags of
+                         False                            -> return LlvmMangle
+                         True | gopt Opt_SplitObjs dflags -> return Splitter
+                         True                             -> return (As False)
 
     output_fn <- phaseOutputFilename next_phase
 
     liftIO $ SysTools.runLlvmLlc dflags
-                ([ SysTools.Option (llvmOpts !! opt_lvl),
-                    SysTools.Option $ "-relocation-model=" ++ rmodel,
-                    SysTools.FileOption "" input_fn,
-                    SysTools.Option "-o", SysTools.FileOption "" output_fn]
-                ++ [SysTools.Option tbaa]
-                ++ map SysTools.Option fpOpts
-                ++ map SysTools.Option abiOpts
-                ++ map SysTools.Option sseOpts
-                ++ map SysTools.Option avxOpts
-                ++ map SysTools.Option avx512Opts
-                ++ map SysTools.Option stackAlignOpts)
+                (  optFlag
+                ++ defaultOptions
+                ++ [ SysTools.FileOption "" input_fn
+                   , SysTools.Option "-o"
+                   , SysTools.FileOption "" output_fn
+                   ]
+                )
 
     return (RealPhase next_phase, output_fn)
   where
-        -- Bug in LLVM at O3 on OSX.
-        llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
-                   then ["-O1", "-O2", "-O2"]
-                   else ["-O1", "-O2", "-O3"]
-        -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
-        -- while compiling GHC source code. It's probably due to fact that it
-        -- does not enable VFP by default. Let's do this manually here
-        fpOpts = case platformArch (targetPlatform dflags) of
-                   ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)
-                                      then ["-mattr=+v7,+vfp3"]
-                                      else if (elem VFPv3D16 ext)
-                                           then ["-mattr=+v7,+vfp3,+d16"]
-                                           else []
-                   ArchARM ARMv6 ext _ -> if (elem VFPv2 ext)
-                                          then ["-mattr=+v6,+vfp2"]
-                                          else ["-mattr=+v6"]
-                   _                 -> []
-        -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
-        -- compiles into soft-float ABI. We need to explicitly set abi
-        -- to hard
-        abiOpts = case platformArch (targetPlatform dflags) of
-                    ArchARM _ _ HARD -> ["-float-abi=hard"]
-                    ArchARM _ _ _    -> []
-                    _                -> []
-
-        sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"]
-                | isSse2Enabled dflags   = ["-mattr=+sse2"]
-                | isSseEnabled dflags    = ["-mattr=+sse"]
-                | otherwise              = []
-
-        avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"]
-                | isAvx2Enabled dflags    = ["-mattr=+avx2"]
-                | isAvxEnabled dflags     = ["-mattr=+avx"]
-                | otherwise               = []
-
-        avx512Opts =
-          [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++
-          [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] ++
-          [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ]
-
-        stackAlignOpts =
-            case platformArch (targetPlatform dflags) of
-              ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"]
-              _                                -> []
+    -- Note [Clamping of llc optimizations]
+    --
+    -- See #13724
+    --
+    -- we clamp the llc optimization between [1,2]. This is because passing -O0
+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
+    --
+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register
+    --   without an emergency spill slot!
+    --
+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
+    --
+    --
+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
+    --   rts/HeapStackCheck.cmm
+    --
+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358
+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876
+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
+    -- 13 llc                      0x000000010195bf0b main + 491
+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1
+    -- Stack dump:
+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
+    --
+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
+    --
+    llvmOpts = case optLevel dflags of
+      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
+      1 -> "-O1"
+      _ -> "-O2"
+
+    optFlag = if null (getOpts dflags opt_lc)
+              then map SysTools.Option $ words llvmOpts
+              else []
+
+    defaultOptions = map SysTools.Option . concat . fmap words . snd
+                   $ unzip (llvmOptions dflags)
+
 
 -----------------------------------------------------------------------------
 -- LlvmMangle phase
@@ -1624,143 +1653,6 @@ getLocation src_flavour mod_name = do
                       | otherwise = location3
         return location4
 
-mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
-mkExtraObj dflags extn xs
- = do cFile <- newTempName dflags TFL_CurrentModule extn
-      oFile <- newTempName dflags TFL_GhcSession "o"
-      writeFile cFile xs
-      ccInfo <- liftIO $ getCompilerInfo dflags
-      SysTools.runCc dflags
-                ([Option        "-c",
-                  FileOption "" cFile,
-                  Option        "-o",
-                  FileOption "" oFile]
-                 ++ if extn /= "s"
-                        then cOpts
-                        else asmOpts ccInfo)
-      return oFile
-    where
-      -- Pass a different set of options to the C compiler depending one whether
-      -- we're compiling C or assembler. When compiling C, we pass the usual
-      -- set of include directories and PIC flags.
-      cOpts = map Option (picCCOpts dflags)
-                    ++ map (FileOption "-I")
-                            (includeDirs $ getPackageDetails dflags rtsUnitId)
-
-      -- When compiling assembler code, we drop the usual C options, and if the
-      -- compiler is Clang, we add an extra argument to tell Clang to ignore
-      -- unused command line options. See trac #11684.
-      asmOpts ccInfo =
-            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
-                then [Option "-Qunused-arguments"]
-                else []
-
-
--- When linking a binary, we need to create a C main() function that
--- starts everything off.  This used to be compiled statically as part
--- of the RTS, but that made it hard to change the -rtsopts setting,
--- so now we generate and compile a main() stub as part of every
--- binary and pass the -rtsopts setting directly to the RTS (#5373)
---
-mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
-mkExtraObjToLinkIntoBinary dflags = do
-   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
-      putLogMsg dflags NoReason SevInfo noSrcSpan
-          (defaultUserStyle dflags)
-          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
-           text "    Call hs_init_ghc() from your main() function to set these options.")
-
-   mkExtraObj dflags "c" (showSDoc dflags main)
-
- where
-  main
-   | gopt Opt_NoHsMain dflags = Outputable.empty
-   | otherwise = vcat [
-      text "#include \"Rts.h\"",
-      text "extern StgClosure ZCMain_main_closure;",
-      text "int main(int argc, char *argv[])",
-      char '{',
-      text " RtsConfig __conf = defaultRtsConfig;",
-      text " __conf.rts_opts_enabled = "
-          <> text (show (rtsOptsEnabled dflags)) <> semi,
-      text " __conf.rts_opts_suggestions = "
-          <> text (if rtsOptsSuggestions dflags
-                      then "true"
-                      else "false") <> semi,
-      case rtsOpts dflags of
-         Nothing   -> Outputable.empty
-         Just opts -> text "    __conf.rts_opts= " <>
-                        text (show opts) <> semi,
-      text " __conf.rts_hs_main = true;",
-      text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
-      char '}',
-      char '\n' -- final newline, to keep gcc happy
-     ]
-
--- Write out the link info section into a new assembly file. Previously
--- this was included as inline assembly in the main.c file but this
--- is pretty fragile. gas gets upset trying to calculate relative offsets
--- that span the .note section (notably .text) when debug info is present
-mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
-mkNoteObjsToLinkIntoBinary dflags dep_packages = do
-   link_info <- getLinkInfo dflags dep_packages
-
-   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
-     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
-     else return []
-
-  where
-    link_opts info = hcat [
-      -- "link info" section (see Note [LinkInfo section])
-      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,
-
-      -- ALL generated assembly must have this section to disable
-      -- executable stacks.  See also
-      -- compiler/nativeGen/AsmCodeGen.hs for another instance
-      -- where we need to do this.
-      if platformHasGnuNonexecStack (targetPlatform dflags)
-        then text ".section .note.GNU-stack,\"\","
-             <> sectionType "progbits" <> char '\n'
-        else Outputable.empty
-      ]
-
--- | Return the "link info" string
---
--- See Note [LinkInfo section]
-getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
-getLinkInfo dflags dep_packages = do
-   package_link_opts <- getPackageLinkOpts dflags dep_packages
-   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
-                     then getPackageFrameworks dflags dep_packages
-                     else return []
-   let extra_ld_inputs = ldInputs dflags
-   let
-      link_info = (package_link_opts,
-                   pkg_frameworks,
-                   rtsOpts dflags,
-                   rtsOptsEnabled dflags,
-                   gopt Opt_NoHsMain dflags,
-                   map showOpt extra_ld_inputs,
-                   getOpts dflags opt_l)
-   --
-   return (show link_info)
-
-
-{- Note [LinkInfo section]
-   ~~~~~~~~~~~~~~~~~~~~~~~
-
-The "link info" is a string representing the parameters of the link. We save
-this information in the binary, and the next time we link, if nothing else has
-changed, we use the link info stored in the existing binary to decide whether
-to re-link or not.
-
-The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
-(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
-not follow the specified record-based format (see #11022).
-
--}
-
-
 -----------------------------------------------------------------------------
 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
 
@@ -1792,7 +1684,7 @@ Note [-Xlinker -rpath vs -Wl,-rpath]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 -Wl takes a comma-separated list of options which in the case of
--Wl,-rpath -Wl,some,path,with,commas parses the the path with commas
+-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
 as separate options.
 Buck, the build system, produces paths with commas in them.
 
@@ -1854,6 +1746,16 @@ linkBinary' staticLink dflags o_files dep_packages = do
               in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
          | otherwise = ["-L" ++ l]
 
+    pkg_lib_path_opts <-
+      if gopt Opt_SingleLibFolder dflags
+      then do
+        libs <- getLibs dflags dep_packages
+        tmpDir <- newTempDir dflags
+        sequence_ [ copyFile lib (tmpDir </> basename)
+                  | (lib, basename) <- libs]
+        return [ "-L" ++ tmpDir ]
+      else pure pkg_lib_path_opts
+
     let
       dead_strip
         | gopt Opt_WholeArchiveHsLibs dflags = []
@@ -1932,13 +1834,12 @@ linkBinary' staticLink dflags o_files dep_packages = do
                       ++ [ SysTools.Option "-o"
                          , SysTools.FileOption "" output_fn
                          ]
+                      ++ libmLinkOpts
                       ++ map SysTools.Option (
                          []
 
-                      -- See Note [No PIE eating when linking]
-                      ++ (if sGccSupportsNoPie mySettings
-                             then ["-no-pie"]
-                             else [])
+                      -- See Note [No PIE when linking]
+                      ++ picCCOpts dflags
 
                       -- Permit the linker to auto link _symbol to _imp_symbol.
                       -- This lets us link against DLLs without needing an "import library".
@@ -1956,7 +1857,7 @@ linkBinary' staticLink dflags o_files dep_packages = do
                       -- on x86.
                       ++ (if sLdSupportsCompactUnwind mySettings &&
                              not staticLink &&
-                             (platformOS platform == OSDarwin || platformOS platform == OSiOS) &&
+                             (platformOS platform == OSDarwin) &&
                              case platformArch platform of
                                ArchX86 -> True
                                ArchX86_64 -> True
@@ -1995,6 +1896,9 @@ linkBinary' staticLink dflags o_files dep_packages = do
                       ++ pkg_framework_opts
                       ++ debug_opts
                       ++ thread_opts
+                      ++ (if platformOS platform == OSDarwin
+                          then [ "-Wl,-dead_strip_dylibs" ]
+                          else [])
                     ))
 
 exeFileName :: Bool -> DynFlags -> FilePath
@@ -2079,9 +1983,35 @@ linkDynLibCheck dflags o_files dep_packages
 
     linkDynLib dflags o_files dep_packages
 
-linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
-linkStaticLibCheck dflags o_files dep_packages
- = linkBinary' True dflags o_files dep_packages
+-- | Linking a static lib will not really link anything. It will merely produce
+-- a static archive of all dependent static libraries. The resulting library
+-- will still need to be linked with any remaining link flags.
+linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkStaticLib dflags o_files dep_packages = do
+  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+      modules = o_files ++ extra_ld_inputs
+      output_fn = exeFileName True dflags
+
+  full_output_fn <- if isAbsolute output_fn
+                    then return output_fn
+                    else do d <- getCurrentDirectory
+                            return $ normalise (d </> output_fn)
+  output_exists <- doesFileExist full_output_fn
+  (when output_exists) $ removeFile full_output_fn
+
+  pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
+  archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
+
+  ar <- foldl mappend
+        <$> (Archive <$> mapM loadObj modules)
+        <*> mapM loadAr archives
+
+  if sLdIsGnuLd (settings dflags)
+    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
+    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
+
+  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
+  runRanlib dflags [SysTools.FileOption "" output_fn]
 
 -- -----------------------------------------------------------------------------
 -- Running CPP
@@ -2092,8 +2022,11 @@ doCpp dflags raw input_fn output_fn = do
     let cmdline_include_paths = includePaths dflags
 
     pkg_include_dirs <- getPackageIncludePath dflags []
-    let include_paths = foldr (\ x xs -> "-I" : x : xs) []
-                          (cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+          (includePathsQuote cmdline_include_paths)
+    let include_paths = include_paths_quote ++ include_paths_global
 
     let verbFlags = getVerbFlags dflags
 
@@ -2227,7 +2160,7 @@ joinObjectFiles dflags o_files output_fn = do
                        SysTools.Option "-nostdlib",
                        SysTools.Option "-Wl,-r"
                      ]
-                        -- See Note [No PIE eating while linking] in SysTools
+                        -- See Note [No PIE while linking] in SysTools
                      ++ (if sGccSupportsNoPie mySettings
                           then [SysTools.Option "-no-pie"]
                           else [])
@@ -2300,20 +2233,19 @@ touchObjectFile dflags path = do
   createDirectoryIfMissing True $ takeDirectory path
   SysTools.touch dflags "Touching object file" path
 
-haveRtsOptsFlags :: DynFlags -> Bool
-haveRtsOptsFlags dflags =
-         isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
-                                        RtsOptsSafeOnly -> False
-                                        _ -> True
-
 -- | Find out path to @ghcversion.h@ file
 getGhcVersionPathName :: DynFlags -> IO FilePath
 getGhcVersionPathName dflags = do
-  dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]
+  candidates <- case ghcVersionFile dflags of
+    Just path -> return [path]
+    Nothing -> (map (</> "ghcversion.h")) <$>
+               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
 
-  found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)
+  found <- filterM doesFileExist candidates
   case found of
-      []    -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing"))
+      []    -> throwGhcExceptionIO (InstallationError
+                                    ("ghcversion.h missing; tried: "
+                                      ++ intercalate ", " candidates))
       (x:_) -> return x
 
 -- Note [-fPIC for assembler]
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index cc9bbb8684..9f0ba57bf5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -24,7 +24,7 @@ module DynFlags (
         WarningFlag(..), WarnReason(..),
         Language(..),
         PlatformConstants(..),
-        FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..),
+        FatalMessager, LogAction, FlushOut(..), FlushErr(..),
         ProfAuto(..),
         glasgowExtsFlags,
         warningGroups, warningHierarchies,
@@ -36,6 +36,7 @@ module DynFlags (
         xopt, xopt_set, xopt_unset,
         lang_set,
         useUnicodeSyntax,
+        useStarIsType,
         whenGeneratingDynamicToo, ifGeneratingDynamicToo,
         whenCannotGenerateDynamicToo,
         dynamicTooMkDynamicDynFlags,
@@ -59,6 +60,9 @@ module DynFlags (
         tablesNextToCode, mkTablesNextToCode,
         makeDynFlagsConsistent,
         shouldUseColor,
+        shouldUseHexWordLiterals,
+        positionIndependent,
+        optimisationFlags,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
@@ -75,6 +79,9 @@ module DynFlags (
         safeDirectImpsReq, safeImplicitImpsReq,
         unsafeFlags, unsafeFlagsForInfer,
 
+        -- ** LLVM Targets
+        LlvmTarget(..), LlvmTargets, LlvmPasses, LlvmConfig,
+
         -- ** System tool settings and locations
         Settings(..),
         targetPlatform, programName, projectVersion,
@@ -82,12 +89,13 @@ module DynFlags (
         versionedAppDir,
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
-        pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i,
-        opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
-        opt_windres, opt_lo, opt_lc,
-
+        pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc,
+        pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
+        opt_P_signature,
+        opt_windres, opt_lo, opt_lc, opt_lcc,
 
         -- ** Manipulating DynFlags
+        addPluginModuleName,
         defaultDynFlags,                -- Settings -> DynFlags
         defaultWays,
         interpWays,
@@ -107,6 +115,7 @@ module DynFlags (
         setUnitId,
         interpretPackageEnv,
         canonicalizeHomeModule,
+        canonicalizeModuleIfHome,
 
         -- ** Parsing DynFlags
         parseDynamicFlagsCmdLine,
@@ -145,6 +154,8 @@ module DynFlags (
         isSseEnabled,
         isSse2Enabled,
         isSse4_2Enabled,
+        isBmiEnabled,
+        isBmi2Enabled,
         isAvxEnabled,
         isAvx2Enabled,
         isAvx512cdEnabled,
@@ -157,15 +168,21 @@ module DynFlags (
         CompilerInfo(..),
 
         -- * File cleanup
-        FilesToClean(..), emptyFilesToClean
+        FilesToClean(..), emptyFilesToClean,
+
+        -- * Include specifications
+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Platform
 import PlatformConstants
 import Module
 import PackageConfig
+import {-# SOURCE #-} Plugins
 import {-# SOURCE #-} Hooks
 import {-# SOURCE #-} PrelNames ( mAIN )
 import {-# SOURCE #-} Packages (PackageState, emptyPackageState)
@@ -183,13 +200,15 @@ import qualified Pretty
 import SrcLoc
 import BasicTypes       ( IntWithInf, treatZeroAsInf )
 import FastString
+import Fingerprint
 import Outputable
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
-                               , getCaretDiagnostic, dumpSDoc )
+                               , getCaretDiagnostic )
 import Json
 import SysTools.Terminal ( stderrSupportsAnsiColors )
+import SysTools.BaseDir ( expandToolDir, expandTopDir )
 
 import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
@@ -231,14 +250,8 @@ import Foreign (Ptr) -- needed for 2nd stage
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
 -- If you modify anything in this file please make sure that your changes are
--- described in the User's Guide. Usually at least two sections need to be
--- updated:
---
---  * Flag Reference section generated from the modules in
---    utils/mkUserGuidePart/Options
---
---  * Flag description in docs/users_guide/using.rst provides a detailed
---    explanation of flags' usage.
+-- described in the User's Guide. Please update the flag description in the
+-- users guide (docs/users_guide) whenever you add or change a flag.
 
 -- Note [Supporting CLI completion]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -343,6 +356,7 @@ data DumpFlag
    | Opt_D_dump_core_stats
    | Opt_D_dump_deriv
    | Opt_D_dump_ds
+   | Opt_D_dump_ds_preopt
    | Opt_D_dump_foreign
    | Opt_D_dump_inlinings
    | Opt_D_dump_rule_firings
@@ -360,6 +374,7 @@ data DumpFlag
    | Opt_D_dump_prep
    | Opt_D_dump_stg
    | Opt_D_dump_call_arity
+   | Opt_D_dump_exitify
    | Opt_D_dump_stranal
    | Opt_D_dump_str_signatures
    | Opt_D_dump_tc
@@ -380,7 +395,6 @@ data DumpFlag
    | Opt_D_dump_splices
    | Opt_D_th_dec_file
    | Opt_D_dump_BCOs
-   | Opt_D_dump_vect
    | Opt_D_dump_ticked
    | Opt_D_dump_rtti
    | Opt_D_source_stats
@@ -389,6 +403,7 @@ data DumpFlag
    | Opt_D_dump_hi_diffs
    | Opt_D_dump_mod_cycles
    | Opt_D_dump_mod_map
+   | Opt_D_dump_timings
    | Opt_D_dump_view_pattern_commoning
    | Opt_D_verbose_core2core
    | Opt_D_dump_debug
@@ -397,6 +412,7 @@ data DumpFlag
    | Opt_D_no_debug_output
    deriving (Eq, Show, Enum)
 
+
 -- | Enumerates the simple on-or-off dynamic flags
 data GeneralFlag
 -- See Note [Updating flag description in the User's Guide]
@@ -410,6 +426,7 @@ data GeneralFlag
    | Opt_DoAsmLinting
    | Opt_DoAnnotationLinting
    | Opt_NoLlvmMangler                 -- hidden flag
+   | Opt_FastLlvm                      -- hidden flag
 
    | Opt_WarnIsError                    -- -Werror; makes warnings fatal
    | Opt_ShowWarnGroups                 -- Show the group a warning belongs to
@@ -427,12 +444,14 @@ data GeneralFlag
 
    -- optimisation opts
    | Opt_CallArity
+   | Opt_Exitification
    | Opt_Strictness
-   | Opt_LateDmdAnal
+   | Opt_LateDmdAnal                    -- #6087
    | Opt_KillAbsence
    | Opt_KillOneShot
    | Opt_FullLaziness
    | Opt_FloatIn
+   | Opt_LateSpecialise
    | Opt_Specialise
    | Opt_SpecialiseAggressively
    | Opt_CrossModuleSpecialise
@@ -451,8 +470,6 @@ data GeneralFlag
    | Opt_UnboxSmallStrictFields
    | Opt_DictsCheap
    | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification
-   | Opt_Vectorise
-   | Opt_VectorisationAvoidance
    | Opt_RegsGraph                      -- do graph coloring register allocation
    | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation
    | Opt_PedanticBottoms                -- Be picky about how we treat bottom
@@ -462,6 +479,7 @@ data GeneralFlag
    | Opt_IrrefutableTuples
    | Opt_CmmSink
    | Opt_CmmElimCommonBlocks
+   | Opt_AsmShortcutting
    | Opt_OmitYields
    | Opt_FunToThunk               -- allow WwLib.mkWorkerArgs to remove all value lambdas
    | Opt_DictsStrict                     -- be strict in argument dictionaries
@@ -470,7 +488,13 @@ data GeneralFlag
    | Opt_CprAnal
    | Opt_WorkerWrapper
    | Opt_SolveConstantDicts
+   | Opt_AlignmentSanitisation
    | Opt_CatchBottoms
+   | Opt_NumConstantFolding
+
+   -- PreInlining is on by default. The option is there just to see how
+   -- bad things get if you turn it off!
+   | Opt_SimplPreInlining
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -485,6 +509,8 @@ data GeneralFlag
    -- misc opts
    | Opt_Pp
    | Opt_ForceRecomp
+   | Opt_IgnoreOptimChanges
+   | Opt_IgnoreHpcChanges
    | Opt_ExcessPrecision
    | Opt_EagerBlackHoling
    | Opt_NoHsMain
@@ -507,12 +533,17 @@ data GeneralFlag
    | Opt_IgnoreDotGhci
    | Opt_GhciSandbox
    | Opt_GhciHistory
+   | Opt_GhciLeakCheck
    | Opt_LocalGhciHistory
+   | Opt_NoIt
    | Opt_HelpfulErrors
    | Opt_DeferTypeErrors
    | Opt_DeferTypedHoles
    | Opt_DeferOutOfScopeVariables
-   | Opt_PIC
+   | Opt_PIC                         -- ^ @-fPIC@
+   | Opt_PIE                         -- ^ @-fPIE@
+   | Opt_PICExecutable               -- ^ @-pie@
+   | Opt_ExternalDynamicRefs
    | Opt_SccProfilingOn
    | Opt_Ticky
    | Opt_Ticky_Allocd
@@ -526,10 +557,13 @@ data GeneralFlag
    | Opt_OptimalApplicativeDo
    | Opt_VersionMacros
    | Opt_WholeArchiveHsLibs
-
-   -- PreInlining is on by default. The option is there just to see how
-   -- bad things get if you turn it off!
-   | Opt_SimplPreInlining
+   -- copy all libs into a single folder prior to linking binaries
+   -- this should elivate the excessive command line limit restrictions
+   -- on windows, by only requiring a single -L argument instead of
+   -- one for each dependency.  At the time of this writing, gcc
+   -- forwards all -L flags to the collect2 command without using a
+   -- response file and as such breaking apart.
+   | Opt_SingleLibFolder
 
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
@@ -538,6 +572,24 @@ data GeneralFlag
    | Opt_PprCaseAsLet
    | Opt_PprShowTicks
    | Opt_ShowHoleConstraints
+    -- Options relating to the display of valid hole fits
+    -- when generating an error message for a typed hole
+    -- See Note [Valid hole fits include] in TcHoleErrors.hs
+   | Opt_ShowValidHoleFits
+   | Opt_SortValidHoleFits
+   | Opt_SortBySizeHoleFits
+   | Opt_SortBySubsumHoleFits
+   | Opt_AbstractRefHoleFits
+   | Opt_UnclutterValidHoleFits
+   | Opt_ShowTypeAppOfHoleFits
+   | Opt_ShowTypeAppVarsOfHoleFits
+   | Opt_ShowDocsOfHoleFits
+   | Opt_ShowTypeOfHoleFits
+   | Opt_ShowProvOfHoleFits
+   | Opt_ShowMatchesOfHoleFits
+
+   | Opt_ShowLoadedModules
+   | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]
 
    -- Suppress all coercions, them replacing with '...'
    | Opt_SuppressCoercions
@@ -557,13 +609,16 @@ data GeneralFlag
    -- Except for uniques, as some simplifier phases introduce new
    -- variables that have otherwise identical names.
    | Opt_SuppressUniques
+   | Opt_SuppressStgFreeVars
    | Opt_SuppressTicks     -- Replaces Opt_PprShowTicks
+   | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
 
    -- temporary flags
    | Opt_AutoLinkPackages
    | Opt_ImplicitImportQualified
 
    -- keeping stuff
+   | Opt_KeepHscppFiles
    | Opt_KeepHiDiffs
    | Opt_KeepHcFiles
    | Opt_KeepSFiles
@@ -583,6 +638,65 @@ data GeneralFlag
    | Opt_G_NoOptCoercion
    deriving (Eq, Show, Enum)
 
+-- Check whether a flag should be considered an "optimisation flag"
+-- for purposes of recompilation avoidance (see
+-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is
+-- not a guarantee that the flag has no other effect. We could, and
+-- perhaps should, separate out the flags that have some minor impact on
+-- program semantics and/or error behavior (e.g., assertions), but
+-- then we'd need to go to extra trouble (and an additional flag)
+-- to allow users to ignore the optimisation level even though that
+-- means ignoring some change.
+optimisationFlags :: EnumSet GeneralFlag
+optimisationFlags = EnumSet.fromList
+   [ Opt_CallArity
+   , Opt_Strictness
+   , Opt_LateDmdAnal
+   , Opt_KillAbsence
+   , Opt_KillOneShot
+   , Opt_FullLaziness
+   , Opt_FloatIn
+   , Opt_LateSpecialise
+   , Opt_Specialise
+   , Opt_SpecialiseAggressively
+   , Opt_CrossModuleSpecialise
+   , Opt_StaticArgumentTransformation
+   , Opt_CSE
+   , Opt_StgCSE
+   , Opt_LiberateCase
+   , Opt_SpecConstr
+   , Opt_SpecConstrKeen
+   , Opt_DoLambdaEtaExpansion
+   , Opt_IgnoreAsserts
+   , Opt_DoEtaReduction
+   , Opt_CaseMerge
+   , Opt_CaseFolding
+   , Opt_UnboxStrictFields
+   , Opt_UnboxSmallStrictFields
+   , Opt_DictsCheap
+   , Opt_EnableRewriteRules
+   , Opt_RegsGraph
+   , Opt_RegsIterative
+   , Opt_PedanticBottoms
+   , Opt_LlvmTBAA
+   , Opt_LlvmPassVectorsInRegisters
+   , Opt_LlvmFillUndefWithGarbage
+   , Opt_IrrefutableTuples
+   , Opt_CmmSink
+   , Opt_CmmElimCommonBlocks
+   , Opt_AsmShortcutting
+   , Opt_OmitYields
+   , Opt_FunToThunk
+   , Opt_DictsStrict
+   , Opt_DmdTxDictSel
+   , Opt_Loopification
+   , Opt_CprAnal
+   , Opt_WorkerWrapper
+   , Opt_SolveConstantDicts
+   , Opt_CatchBottoms
+   , Opt_IgnoreAsserts
+   ]
+
 -- | Used when outputting warnings: if a reason is given, it is
 -- displayed. If a warning isn't controlled by a flag, this is made
 -- explicit at the point of use.
@@ -594,6 +708,33 @@ data WarnReason
   | ErrReason !(Maybe WarningFlag)
   deriving Show
 
+-- | Used to differentiate the scope an include needs to apply to.
+-- We have to split the include paths to avoid accidentally forcing recursive
+-- includes since -I overrides the system search paths. See Trac #14312.
+data IncludeSpecs
+  = IncludeSpecs { includePathsQuote  :: [String]
+                 , includePathsGlobal :: [String]
+                 }
+  deriving Show
+
+-- | Append to the list of includes a path that shall be included using `-I`
+-- when the C compiler is called. These paths override system search paths.
+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addGlobalInclude spec paths  = let f = includePathsGlobal spec
+                               in spec { includePathsGlobal = f ++ paths }
+
+-- | Append to the list of includes a path that shall be included using
+-- `-iquote` when the C compiler is called. These paths only apply when quoted
+-- includes are used. e.g. #include "foo.h"
+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs
+addQuoteInclude spec paths  = let f = includePathsQuote spec
+                              in spec { includePathsQuote = f ++ paths }
+
+-- | Concatenate and flatten the list of global and quoted includes returning
+-- just a flat list of paths.
+flattenIncludes :: IncludeSpecs -> [String]
+flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs
+
 instance Outputable WarnReason where
   ppr = text . show
 
@@ -633,7 +774,6 @@ data WarningFlag =
    | Opt_WarnUnusedForalls
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
-   | Opt_WarnAMP -- Introduced in GHC 7.8, obsolete since 7.10
    | Opt_WarnMissingMonadFailInstances -- since 8.0
    | Opt_WarnSemigroup -- since 8.0
    | Opt_WarnDodgyExports
@@ -671,6 +811,12 @@ data WarningFlag =
    | Opt_WarnCPPUndef                     -- Since 8.2
    | Opt_WarnUnbangedStrictPatterns       -- Since 8.2
    | Opt_WarnMissingHomeModules           -- Since 8.2
+   | Opt_WarnPartialFields                -- Since 8.4
+   | Opt_WarnMissingExportList
+   | Opt_WarnInaccessibleCode
+   | Opt_WarnStarIsType                   -- Since 8.6
+   | Opt_WarnStarBinder                   -- Since 8.6
+   | Opt_WarnImplicitKindVars             -- Since 8.6
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -703,6 +849,8 @@ data DynFlags = DynFlags {
   ghcLink               :: GhcLink,
   hscTarget             :: HscTarget,
   settings              :: Settings,
+  llvmTargets           :: LlvmTargets,
+  llvmPasses            :: LlvmPasses,
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
   optLevel              :: Int,         -- ^ Optimisation level
   debugLevel            :: Int,         -- ^ How much debug information to produce
@@ -710,6 +858,7 @@ data DynFlags = DynFlags {
   maxSimplIterations    :: Int,         -- ^ Max simplifier iterations
   maxPmCheckIterations  :: Int,         -- ^ Max no iterations for pm checking
   ruleCheck             :: Maybe String,
+  inlineCheck           :: Maybe String, -- ^ A prefix to report inlining decisions about
   strictnessBefore      :: [Int],       -- ^ Additional demand analysis
 
   parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel
@@ -721,8 +870,14 @@ data DynFlags = DynFlags {
 
   maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt
                                         --   to show in type error messages
-  maxValidSubstitutions :: Maybe Int,   -- ^ Maximum number of substitutions
-                                        --   to show in type error messages
+  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show
+                                        --   in typed hole error messages
+  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole
+                                        --   fits to show in typed hole error
+                                        --   messages
+  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for
+                                        --   refinement hole fits in typed hole
+                                        --   error messages
   maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show
                                         --   in non-exhaustiveness warnings
   simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks
@@ -734,6 +889,8 @@ data DynFlags = DynFlags {
   floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating
                                         --   See CoreMonad.FloatOutSwitches
 
+  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.
+
   historySize           :: Int,         -- ^ Simplification history size
 
   importPaths           :: [FilePath],
@@ -769,14 +926,6 @@ data DynFlags = DynFlags {
   dynObjectSuf          :: String,
   dynHiSuf              :: String,
 
-  -- Packages.isDllName needs to know whether a call is within a
-  -- single DLL or not. Normally it does this by seeing if the call
-  -- is to the same package, but for the ghc package, we split the
-  -- package between 2 DLLs. The dllSplit tells us which sets of
-  -- modules are in which package.
-  dllSplitFile          :: Maybe FilePath,
-  dllSplit              :: Maybe [Set String],
-
   outputFile            :: Maybe String,
   dynOutputFile         :: Maybe String,
   outputHi              :: Maybe String,
@@ -792,7 +941,7 @@ data DynFlags = DynFlags {
 
   ldInputs              :: [Option],
 
-  includePaths          :: [String],
+  includePaths          :: IncludeSpecs,
   libraryPaths          :: [String],
   frameworkPaths        :: [String],    -- used on darwin only
   cmdlineFrameworks     :: [String],    -- ditto
@@ -809,6 +958,12 @@ data DynFlags = DynFlags {
   frontendPluginOpts    :: [String],
     -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
     -- order that they're specified on the command line.
+  plugins               :: [LoadedPlugin],
+    -- ^ plugins loaded after processing arguments. What will be loaded here
+    -- is directed by pluginModNames. Arguments are loaded from
+    -- pluginModNameOpts. The purpose of this field is to cache the plugins so
+    -- they don't have to be loaded each time they are needed.
+    -- See 'DynamicLoading.initializePlugins'.
 
   -- GHC API hooks
   hooks                 :: Hooks,
@@ -906,12 +1061,11 @@ data DynFlags = DynFlags {
   ghciHistSize          :: Int,
 
   -- | MsgDoc output action: use "ErrUtils" instead of this if you can
-  initLogAction         :: IO (Maybe LogOutput),
   log_action            :: LogAction,
-  log_finaliser         :: LogFinaliser,
   flushOut              :: FlushOut,
   flushErr              :: FlushErr,
 
+  ghcVersionFile        :: Maybe FilePath,
   haddockOptions        :: Maybe String,
 
   -- | GHCi scripts specified by -ghci-script, in reverse order
@@ -935,6 +1089,7 @@ data DynFlags = DynFlags {
 
   -- | Machine dependent flags (-m<blah> stuff)
   sseVersion            :: Maybe SseVersion,
+  bmiVersion            :: Maybe BmiVersion,
   avx                   :: Bool,
   avx2                  :: Bool,
   avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.
@@ -1007,11 +1162,22 @@ data ProfAuto
   | ProfAutoCalls      -- ^ annotate call-sites
   deriving (Eq,Enum)
 
+data LlvmTarget = LlvmTarget
+  { lDataLayout :: String
+  , lCPU        :: String
+  , lAttributes :: [String]
+  }
+
+type LlvmTargets = [(String, LlvmTarget)]
+type LlvmPasses = [(Int, String)]
+type LlvmConfig = (LlvmTargets, LlvmPasses)
+
 data Settings = Settings {
-  sTargetPlatform        :: Platform,    -- Filled in by SysTools
-  sGhcUsagePath          :: FilePath,    -- Filled in by SysTools
-  sGhciUsagePath         :: FilePath,    -- ditto
-  sTopDir                :: FilePath,
+  sTargetPlatform        :: Platform,       -- Filled in by SysTools
+  sGhcUsagePath          :: FilePath,       -- ditto
+  sGhciUsagePath         :: FilePath,       -- ditto
+  sToolDir               :: Maybe FilePath, -- ditto
+  sTopDir                :: FilePath,       -- ditto
   sTmpDir                :: String,      -- no trailing '/'
   sProgramName           :: String,
   sProjectVersion        :: String,
@@ -1037,12 +1203,17 @@ data Settings = Settings {
   sPgm_T                 :: String,
   sPgm_windres           :: String,
   sPgm_libtool           :: String,
+  sPgm_ar                :: String,
+  sPgm_ranlib            :: String,
   sPgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser
   sPgm_lc                :: (String,[Option]), -- LLVM: llc static compiler
+  sPgm_lcc               :: (String,[Option]), -- LLVM: c compiler
   sPgm_i                 :: String,
   -- options for particular phases
   sOpt_L                 :: [String],
   sOpt_P                 :: [String],
+  sOpt_P_fingerprint     :: Fingerprint, -- cached Fingerprint of sOpt_P
+                                         -- See Note [Repeated -optP hashing]
   sOpt_F                 :: [String],
   sOpt_c                 :: [String],
   sOpt_a                 :: [String],
@@ -1050,6 +1221,7 @@ data Settings = Settings {
   sOpt_windres           :: [String],
   sOpt_lo                :: [String], -- LLVM: llvm optimiser
   sOpt_lc                :: [String], -- LLVM: llc static compiler
+  sOpt_lcc               :: [String], -- LLVM: c compiler
   sOpt_i                 :: [String], -- iserv options
 
   sPlatformConstants     :: PlatformConstants
@@ -1065,6 +1237,8 @@ ghcUsagePath          :: DynFlags -> FilePath
 ghcUsagePath dflags = sGhcUsagePath (settings dflags)
 ghciUsagePath         :: DynFlags -> FilePath
 ghciUsagePath dflags = sGhciUsagePath (settings dflags)
+toolDir               :: DynFlags -> Maybe FilePath
+toolDir dflags = sToolDir (settings dflags)
 topDir                :: DynFlags -> FilePath
 topDir dflags = sTopDir (settings dflags)
 tmpDir                :: DynFlags -> String
@@ -1097,6 +1271,12 @@ pgm_windres           :: DynFlags -> String
 pgm_windres dflags = sPgm_windres (settings dflags)
 pgm_libtool           :: DynFlags -> String
 pgm_libtool dflags = sPgm_libtool (settings dflags)
+pgm_lcc               :: DynFlags -> (String,[Option])
+pgm_lcc dflags = sPgm_lcc (settings dflags)
+pgm_ar                :: DynFlags -> String
+pgm_ar dflags = sPgm_ar (settings dflags)
+pgm_ranlib            :: DynFlags -> String
+pgm_ranlib dflags = sPgm_ranlib (settings dflags)
 pgm_lo                :: DynFlags -> (String,[Option])
 pgm_lo dflags = sPgm_lo (settings dflags)
 pgm_lc                :: DynFlags -> (String,[Option])
@@ -1108,6 +1288,14 @@ opt_L dflags = sOpt_L (settings dflags)
 opt_P                 :: DynFlags -> [String]
 opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)
             ++ sOpt_P (settings dflags)
+
+-- This function packages everything that's needed to fingerprint opt_P
+-- flags. See Note [Repeated -optP hashing].
+opt_P_signature       :: DynFlags -> ([String], Fingerprint)
+opt_P_signature dflags =
+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)
+  , sOpt_P_fingerprint (settings dflags))
+
 opt_F                 :: DynFlags -> [String]
 opt_F dflags = sOpt_F (settings dflags)
 opt_c                 :: DynFlags -> [String]
@@ -1120,6 +1308,8 @@ opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)
             ++ sOpt_l (settings dflags)
 opt_windres           :: DynFlags -> [String]
 opt_windres dflags = sOpt_windres (settings dflags)
+opt_lcc                :: DynFlags -> [String]
+opt_lcc dflags = sOpt_lcc (settings dflags)
 opt_lo                :: DynFlags -> [String]
 opt_lo dflags = sOpt_lo (settings dflags)
 opt_lc                :: DynFlags -> [String]
@@ -1319,12 +1509,22 @@ data DynLibLoader
   | SystemDependent
   deriving Eq
 
-data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
+data RtsOptsEnabled
+  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly
+  | RtsOptsAll
   deriving (Show)
 
 shouldUseColor :: DynFlags -> Bool
 shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
 
+shouldUseHexWordLiterals :: DynFlags -> Bool
+shouldUseHexWordLiterals dflags =
+  Opt_HexWordLiterals `EnumSet.member` generalFlags dflags
+
+-- | Are we building with @-fPIE@ or @-fPIC@ enabled?
+positionIndependent :: DynFlags -> Bool
+positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags
+
 -----------------------------------------------------------------------------
 -- Ways
 
@@ -1404,7 +1604,7 @@ wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
 wayGeneralFlags _ (WayCustom {}) = []
 wayGeneralFlags _ WayThreaded = []
 wayGeneralFlags _ WayDebug    = []
-wayGeneralFlags _ WayDyn      = [Opt_PIC]
+wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]
     -- We could get away without adding -fPIC when compiling the
     -- modules of a program that is to be linked with -dynamic; the
     -- program itself does not need to be position-independent, only
@@ -1547,8 +1747,8 @@ initDynFlags dflags = do
 
 -- | The normal 'DynFlags'. Note that they are not suitable for use in this form
 -- and must be fully initialized by 'GHC.runGhc' first.
-defaultDynFlags :: Settings -> DynFlags
-defaultDynFlags mySettings =
+defaultDynFlags :: Settings -> LlvmConfig -> DynFlags
+defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
 -- See Note [Updating flag description in the User's Guide]
      DynFlags {
         ghcMode                 = CompManager,
@@ -1561,8 +1761,11 @@ defaultDynFlags mySettings =
         maxSimplIterations      = 4,
         maxPmCheckIterations    = 2000000,
         ruleCheck               = Nothing,
+        inlineCheck             = Nothing,
         maxRelevantBinds        = Just 6,
-        maxValidSubstitutions   = Just 6,
+        maxValidHoleFits   = Just 6,
+        maxRefHoleFits     = Just 6,
+        refLevelHoleFits   = Nothing,
         maxUncoveredPatterns    = 4,
         simplTickFactor         = 100,
         specConstrThreshold     = Just 2000,
@@ -1570,6 +1773,7 @@ defaultDynFlags mySettings =
         specConstrRecursive     = 3,
         liberateCaseThreshold   = Just 2000,
         floatLamArgs            = Just 0, -- Default: float only if no fvs
+        cmmProcAlignment        = Nothing,
 
         historySize             = 20,
         strictnessBefore        = [],
@@ -1603,12 +1807,10 @@ defaultDynFlags mySettings =
         dynObjectSuf            = "dyn_" ++ phaseInputExt StopLn,
         dynHiSuf                = "dyn_hi",
 
-        dllSplitFile            = Nothing,
-        dllSplit                = Nothing,
-
         pluginModNames          = [],
         pluginModNameOpts       = [],
         frontendPluginOpts      = [],
+        plugins                 = [],
         hooks                   = emptyHooks,
 
         outputFile              = Nothing,
@@ -1618,7 +1820,7 @@ defaultDynFlags mySettings =
         dumpPrefix              = Nothing,
         dumpPrefixForce         = Nothing,
         ldInputs                = [],
-        includePaths            = [],
+        includePaths            = IncludeSpecs [] [],
         libraryPaths            = [],
         frameworkPaths          = [],
         cmdlineFrameworks       = [],
@@ -1641,6 +1843,9 @@ defaultDynFlags mySettings =
         buildTag                = mkBuildTag (defaultWays mySettings),
         splitInfo               = Nothing,
         settings                = mySettings,
+        llvmTargets             = myLlvmTargets,
+        llvmPasses              = myLlvmPasses,
+
         -- ghc -M values
         depMakefile       = "Makefile",
         depIncludePkgDeps = False,
@@ -1651,6 +1856,7 @@ defaultDynFlags mySettings =
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
         generatedDumps = panic "defaultDynFlags: No generatedDumps",
+        ghcVersionFile = Nothing,
         haddockOptions = Nothing,
         dumpFlags = EnumSet.empty,
         generalFlags = EnumSet.fromList (defaultFlags mySettings),
@@ -1693,10 +1899,7 @@ defaultDynFlags mySettings =
 
         -- Logging
 
-        initLogAction = defaultLogOutput,
-
         log_action = defaultLogAction,
-        log_finaliser = \ _ -> return (),
 
         flushOut = defaultFlushOut,
         flushErr = defaultFlushErr,
@@ -1710,6 +1913,7 @@ defaultDynFlags mySettings =
         interactivePrint = Nothing,
         nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
         sseVersion = Nothing,
+        bmiVersion = Nothing,
         avx = False,
         avx2 = False,
         avx512cd = False,
@@ -1756,9 +1960,10 @@ interpreterDynamic dflags
 -- Note [JSON Error Messages]
 --
 -- When the user requests the compiler output to be dumped as json
--- we modify the log_action to collect all the messages in an IORef
--- and then finally in GHC.withCleanupSession the log_finaliser is
--- called which prints out the messages together.
+-- we used to collect them all in an IORef and then print them at the end.
+-- This doesn't work very well with GHCi. (See #14078) So instead we now
+-- use the simpler method of just outputting a JSON document inplace to
+-- stdout.
 --
 -- Before the compiler calls log_action, it has already turned the `ErrMsg`
 -- into a formatted message. This means that we lose some possible
@@ -1768,14 +1973,6 @@ interpreterDynamic dflags
 
 type FatalMessager = String -> IO ()
 
-data LogOutput = LogOutput
-               { getLogAction :: LogAction
-               , getLogFinaliser :: LogFinaliser
-               }
-
-defaultLogOutput :: IO (Maybe LogOutput)
-defaultLogOutput = return $ Nothing
-
 type LogAction = DynFlags
               -> WarnReason
               -> Severity
@@ -1784,41 +1981,24 @@ type LogAction = DynFlags
               -> MsgDoc
               -> IO ()
 
-type LogFinaliser = DynFlags -> IO ()
-
 defaultFatalMessager :: FatalMessager
 defaultFatalMessager = hPutStrLn stderr
 
 
 -- See Note [JSON Error Messages]
-jsonLogOutput :: IO (Maybe LogOutput)
-jsonLogOutput = do
-  ref <- newIORef []
-  return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref)
-
-jsonLogAction :: IORef [SDoc] -> LogAction
-jsonLogAction iref dflags reason severity srcSpan style msg
+--
+jsonLogAction :: LogAction
+jsonLogAction dflags reason severity srcSpan _style msg
   = do
-      addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $
-        JSObject [ ( "span", json srcSpan )
-                 , ( "doc" , JSString (showSDoc dflags msg) )
-                 , ( "severity", json severity )
-                 , ( "reason" ,   json reason )
-                ]
-      defaultLogAction dflags reason severity srcSpan style msg
-  where
-    addMessage m = modifyIORef iref (m:)
-
-
-jsonLogFinaliser :: IORef [SDoc] -> DynFlags -> IO ()
-jsonLogFinaliser iref dflags = do
-  msgs <- readIORef iref
-  let fmt_msgs = brackets $ pprWithCommas (blankLine $$) msgs
-  output fmt_msgs
-  where
-    -- dumpSDoc uses log_action to output the dump
-    dflags' = dflags { log_action = defaultLogAction }
-    output doc = dumpSDoc dflags' neverQualify Opt_D_dump_json "" doc
+    defaultLogActionHPutStrDoc dflags stdout (doc $$ text "")
+                               (mkCodeStyle CStyle)
+    where
+      doc = renderJSON $
+              JSObject [ ( "span", json srcSpan )
+                       , ( "doc" , JSString (showSDoc dflags msg) )
+                       , ( "severity", json severity )
+                       , ( "reason" ,   json reason )
+                       ]
 
 
 defaultLogAction :: LogAction
@@ -1935,6 +2115,9 @@ languageExtensions Nothing
 
 languageExtensions (Just Haskell98)
     = [LangExt.ImplicitPrelude,
+       -- See Note [When is StarIsType enabled]
+       LangExt.StarIsType,
+       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.NPlusKPatterns,
        LangExt.DatatypeContexts,
@@ -1949,6 +2132,9 @@ languageExtensions (Just Haskell98)
 
 languageExtensions (Just Haskell2010)
     = [LangExt.ImplicitPrelude,
+       -- See Note [When is StarIsType enabled]
+       LangExt.StarIsType,
+       LangExt.MonadFailDesugaring,
        LangExt.MonomorphismRestriction,
        LangExt.DatatypeContexts,
        LangExt.TraditionalRecordSyntax,
@@ -2083,6 +2269,9 @@ lang_set dflags lang =
 useUnicodeSyntax :: DynFlags -> Bool
 useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax
 
+useStarIsType :: DynFlags -> Bool
+useStarIsType = xopt LangExt.StarIsType
+
 -- | Set the Haskell language standard to use
 setLanguage :: Language -> DynP ()
 setLanguage l = upd (`lang_set` Just l)
@@ -2195,7 +2384,8 @@ setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce
 
 setObjectDir  f d = d { objectDir  = Just f}
 setHiDir      f d = d { hiDir      = Just f}
-setStubDir    f d = d { stubDir    = Just f, includePaths = f : includePaths d }
+setStubDir    f d = d { stubDir    = Just f
+                      , includePaths = addGlobalInclude (includePaths d) [f] }
   -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
   -- \#included from the .hc file when compiling via C (i.e. unregisterised
   -- builds).
@@ -2214,7 +2404,7 @@ setDynOutputFile f d = d { dynOutputFile = f}
 setOutputHi   f d = d { outputHi   = f}
 
 setJsonLogAction :: DynFlags -> DynFlags
-setJsonLogAction d = d { initLogAction = jsonLogOutput }
+setJsonLogAction d = d { log_action = jsonLogAction }
 
 thisComponentId :: DynFlags -> ComponentId
 thisComponentId dflags =
@@ -2289,7 +2479,12 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f}
 setPgmP   f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P   = (pgm, map Option args)})
 addOptl   f = alterSettings (\s -> s { sOpt_l   = f : sOpt_l s})
 addOptc   f = alterSettings (\s -> s { sOpt_c   = f : sOpt_c s})
-addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s})
+addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s
+                                     , sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s)
+                                     })
+                                     -- See Note [Repeated -optP hashing]
+  where
+  fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
 
 
 setDepMakefile :: FilePath -> DynFlags -> DynFlags
@@ -2307,6 +2502,9 @@ addDepSuffix s d = d { depSuffixes = s : depSuffixes d }
 
 addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}
 
+addGhcVersionFile :: FilePath -> DynFlags -> DynFlags
+addGhcVersionFile f d = d { ghcVersionFile = Just f }
+
 addHaddockOpts f d = d { haddockOptions = Just f}
 
 addGhciScript f d = d { ghciScripts = f : ghciScripts d}
@@ -2419,47 +2617,17 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
 
   let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
 
-  dflags6 <- case dllSplitFile dflags5 of
-             Nothing -> return (dflags5 { dllSplit = Nothing })
-             Just f ->
-                 case dllSplit dflags5 of
-                 Just _ ->
-                     -- If dllSplit is out of date then it would have
-                     -- been set to Nothing. As it's a Just, it must be
-                     -- up-to-date.
-                     return dflags5
-                 Nothing ->
-                     do xs <- liftIO $ readFile f
-                        let ss = map (Set.fromList . words) (lines xs)
-                        return $ dflags5 { dllSplit = Just ss }
-
   -- Set timer stats & heap size
-  when (enableTimeStats dflags6) $ liftIO enableTimingStats
-  case (ghcHeapSize dflags6) of
+  when (enableTimeStats dflags5) $ liftIO enableTimingStats
+  case (ghcHeapSize dflags5) of
     Just x -> liftIO (setHeapSize x)
     _      -> return ()
 
-  dflags7 <- liftIO $ setLogAction dflags6
-
-  liftIO $ setUnsafeGlobalDynFlags dflags7
+  liftIO $ setUnsafeGlobalDynFlags dflags5
 
   let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)
 
-  return (dflags7, leftover, warns' ++ warns)
-
-setLogAction :: DynFlags -> IO DynFlags
-setLogAction dflags = do
- mlogger <- initLogAction dflags
- return $
-    maybe
-         dflags
-         (\logger ->
-            dflags
-              { log_action    = getLogAction logger
-              , log_finaliser = getLogFinaliser logger
-              , initLogAction = return $ Nothing -- Don't initialise it twice
-              })
-         mlogger
+  return (dflags5, leftover, warns' ++ warns)
 
 -- | Write an error or warning to the 'LogOutput'.
 putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle
@@ -2483,7 +2651,7 @@ safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
 safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)
   where
     -- Handle illegal flags under safe language.
-    (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags
+    (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags
 
     check_method (df, warns) (str,loc,test,fix)
         | test df   = (fix df, warns ++ safeFailure (loc df) str)
@@ -2530,11 +2698,8 @@ allNonDeprecatedFlags = allFlagsDeps False
 allFlagsDeps :: Bool -> [String]
 allFlagsDeps keepDeprecated = [ '-':flagName flag
                               | (deprecated, flag) <- flagsAllDeps
-                              , ok (flagOptKind flag)
                               , keepDeprecated || not (isDeprecated deprecated)]
-  where ok (PrefixPred _ _) = False
-        ok _   = True
-        isDeprecated Deprecated = True
+  where isDeprecated Deprecated = True
         isDeprecated _ = False
 
 {-
@@ -2594,10 +2759,6 @@ add_dep_message (PassFlag f) message =
                                    PassFlag $ \s -> f s >> deprecate message
 add_dep_message (AnySuffix f) message =
                                   AnySuffix $ \s -> f s >> deprecate message
-add_dep_message (PrefixPred pred f) message =
-                            PrefixPred pred $ \s -> f s >> deprecate message
-add_dep_message (AnySuffixPred pred f) message =
-                         AnySuffixPred pred $ \s -> f s >> deprecate message
 
 ----------------------- The main flags themselves ------------------------------
 -- See Note [Updating flag description in the User's Guide]
@@ -2663,6 +2824,10 @@ dynamic_flags_deps = [
 #endif
   , make_ord_flag defGhcFlag "relative-dynlib-paths"
       (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))
+  , make_ord_flag defGhcFlag "copy-libs-when-linking"
+      (NoArg (setGeneralFlag Opt_SingleLibFolder))
+  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))
+  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))
 
         ------- Specific phases  --------------------------------------------
     -- need to appear before -pgmL to be parsed as LLVM flags.
@@ -2692,6 +2857,11 @@ dynamic_flags_deps = [
       (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f})))
   , make_ord_flag defFlag "pgmlibtool"
       (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f})))
+  , make_ord_flag defFlag "pgmar"
+      (hasArg (\f -> alterSettings (\s -> s { sPgm_ar = f})))
+  , make_ord_flag defFlag "pgmranlib"
+      (hasArg (\f -> alterSettings (\s -> s { sPgm_ranlib = f})))
+
 
     -- need to appear before -optl/-opta to be parsed as LLVM flags.
   , make_ord_flag defFlag "optlo"
@@ -2746,9 +2916,6 @@ dynamic_flags_deps = [
         (noArg (\d -> d { ghcLink=LinkStaticLib }))
   , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)
   , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)
-    -- -dll-split is an internal flag, used only during the GHC build
-  , make_ord_flag defHiddenFlag "dll-split"
-      (hasArg (\f d -> d { dllSplitFile = Just f, dllSplit = Nothing }))
 
         ------- Libraries ---------------------------------------------------
   , make_ord_flag defFlag "L"   (Prefix addLibraryPath)
@@ -2788,6 +2955,10 @@ dynamic_flags_deps = [
         (NoArg (setGeneralFlag Opt_KeepHcFiles))
   , make_ord_flag defGhcFlag "keep-hc-files"
         (NoArg (setGeneralFlag Opt_KeepHcFiles))
+  , make_ord_flag defGhcFlag "keep-hscpp-file"
+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))
+  , make_ord_flag defGhcFlag "keep-hscpp-files"
+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))
   , make_ord_flag defGhcFlag "keep-s-file"
         (NoArg (setGeneralFlag Opt_KeepSFiles))
   , make_ord_flag defGhcFlag "keep-s-files"
@@ -2835,11 +3006,18 @@ dynamic_flags_deps = [
         (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))
   , make_ord_flag defGhcFlag "rtsopts=none"
         (NoArg (setRtsOptsEnabled RtsOptsNone))
+  , make_ord_flag defGhcFlag "rtsopts=ignore"
+        (NoArg (setRtsOptsEnabled RtsOptsIgnore))
+  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"
+        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))
   , make_ord_flag defGhcFlag "no-rtsopts"
         (NoArg (setRtsOptsEnabled RtsOptsNone))
   , make_ord_flag defGhcFlag "no-rtsopts-suggestions"
       (noArg (\d -> d {rtsOptsSuggestions = False}))
+  , make_ord_flag defGhcFlag "dhex-word-literals"
+        (NoArg (setGeneralFlag Opt_HexWordLiterals))
 
+  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)
   , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)
   , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))
   , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)
@@ -2897,7 +3075,9 @@ dynamic_flags_deps = [
                   setGeneralFlag Opt_SuppressTypeApplications
                   setGeneralFlag Opt_SuppressIdInfo
                   setGeneralFlag Opt_SuppressTicks
-                  setGeneralFlag Opt_SuppressTypeSignatures)
+                  setGeneralFlag Opt_SuppressStgFreeVars
+                  setGeneralFlag Opt_SuppressTypeSignatures
+                  setGeneralFlag Opt_SuppressTimestamps)
 
         ------ Debugging ----------------------------------------------------
   , make_ord_flag defGhcFlag "dstg-stats"
@@ -2957,6 +3137,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_deriv)
   , make_ord_flag defGhcFlag "ddump-ds"
         (setDumpFlag Opt_D_dump_ds)
+  , make_ord_flag defGhcFlag "ddump-ds-preopt"
+        (setDumpFlag Opt_D_dump_ds_preopt)
   , make_ord_flag defGhcFlag "ddump-foreign"
         (setDumpFlag Opt_D_dump_foreign)
   , make_ord_flag defGhcFlag "ddump-inlinings"
@@ -2989,6 +3171,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_stg)
   , make_ord_flag defGhcFlag "ddump-call-arity"
         (setDumpFlag Opt_D_dump_call_arity)
+  , make_ord_flag defGhcFlag "ddump-exitify"
+        (setDumpFlag Opt_D_dump_exitify)
   , make_ord_flag defGhcFlag "ddump-stranal"
         (setDumpFlag Opt_D_dump_stranal)
   , make_ord_flag defGhcFlag "ddump-str-signatures"
@@ -3043,8 +3227,6 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_hi)
   , make_ord_flag defGhcFlag "ddump-minimal-imports"
         (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))
-  , make_ord_flag defGhcFlag "ddump-vect"
-        (setDumpFlag Opt_D_dump_vect)
   , make_ord_flag defGhcFlag "ddump-hpc"
         (setDumpFlag Opt_D_dump_ticked) -- back compat
   , make_ord_flag defGhcFlag "ddump-ticked"
@@ -3053,6 +3235,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_mod_cycles)
   , make_ord_flag defGhcFlag "ddump-mod-map"
         (setDumpFlag Opt_D_dump_mod_map)
+  , make_ord_flag defGhcFlag "ddump-timings"
+        (setDumpFlag Opt_D_dump_timings)
   , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"
         (setDumpFlag Opt_D_dump_view_pattern_commoning)
   , make_ord_flag defGhcFlag "ddump-to-file"
@@ -3077,12 +3261,16 @@ dynamic_flags_deps = [
         (NoArg (setGeneralFlag Opt_D_faststring_stats))
   , make_ord_flag defGhcFlag "dno-llvm-mangler"
         (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag
+  , make_ord_flag defGhcFlag "fast-llvm"
+        (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag
   , make_ord_flag defGhcFlag "ddump-debug"
         (setDumpFlag Opt_D_dump_debug)
   , make_ord_flag defGhcFlag "ddump-json"
         (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )
   , make_ord_flag defGhcFlag "dppr-debug"
         (setDumpFlag Opt_D_ppr_debug)
+  , make_ord_flag defGhcFlag "ddebug-output"
+        (noArg (flip dopt_unset Opt_D_no_debug_output))
   , make_ord_flag defGhcFlag "dno-debug-output"
         (setDumpFlag Opt_D_no_debug_output)
 
@@ -3098,6 +3286,10 @@ dynamic_flags_deps = [
                                                   d { sseVersion = Just SSE4 }))
   , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->
                                                  d { sseVersion = Just SSE42 }))
+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->
+                                                 d { bmiVersion = Just BMI1 }))
+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->
+                                                 d { bmiVersion = Just BMI2 }))
   , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))
   , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))
   , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->
@@ -3160,7 +3352,6 @@ dynamic_flags_deps = [
         ------ Optimisation flags ------------------------------------------
   , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )
                                                             "Use -O0 instead"
-  , make_ord_flag defGhcFlag "Odph"   (noArgM setDPHOpt)
   , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->
                                                 setOptLevel (mb_n `orElse` 1)))
                 -- If the number is missing, use 1
@@ -3170,10 +3361,20 @@ dynamic_flags_deps = [
       (intSuffix (\n d -> d { maxRelevantBinds = Just n }))
   , make_ord_flag defFlag "fno-max-relevant-binds"
       (noArg (\d -> d { maxRelevantBinds = Nothing }))
-  , make_ord_flag defFlag "fmax-valid-substitutions"
-      (intSuffix (\n d -> d { maxValidSubstitutions = Just n }))
-  , make_ord_flag defFlag "fno-max-valid-substitutions"
-      (noArg (\d -> d { maxValidSubstitutions = Nothing }))
+
+  , make_ord_flag defFlag "fmax-valid-hole-fits"
+      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))
+  , make_ord_flag defFlag "fno-max-valid-hole-fits"
+      (noArg (\d -> d { maxValidHoleFits = Nothing }))
+  , make_ord_flag defFlag "fmax-refinement-hole-fits"
+      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))
+  , make_ord_flag defFlag "fno-max-refinement-hole-fits"
+      (noArg (\d -> d { maxRefHoleFits = Nothing }))
+  , make_ord_flag defFlag "frefinement-level-hole-fits"
+      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))
+  , make_ord_flag defFlag "fno-refinement-level-hole-fits"
+      (noArg (\d -> d { refLevelHoleFits = Nothing }))
+
   , make_ord_flag defFlag "fmax-uncovered-patterns"
       (intSuffix (\n d -> d { maxUncoveredPatterns = n }))
   , make_ord_flag defFlag "fsimplifier-phases"
@@ -3198,8 +3399,10 @@ dynamic_flags_deps = [
       (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))
   , make_ord_flag defFlag "fno-liberate-case-threshold"
       (noArg (\d -> d { liberateCaseThreshold = Nothing }))
-  , make_ord_flag defFlag "frule-check"
+  , make_ord_flag defFlag "drule-check"
       (sepArg (\s d -> d { ruleCheck = Just s }))
+  , make_ord_flag defFlag "dinline-check"
+      (sepArg (\s d -> d { inlineCheck = Just s }))
   , make_ord_flag defFlag "freduction-depth"
       (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))
   , make_ord_flag defFlag "fconstraint-solver-iterations"
@@ -3218,6 +3421,10 @@ dynamic_flags_deps = [
       (intSuffix (\n d -> d { floatLamArgs = Just n }))
   , make_ord_flag defFlag "ffloat-all-lams"
       (noArg (\d -> d { floatLamArgs = Nothing }))
+  , make_ord_flag defFlag "fproc-alignment"
+      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))
+
+
   , make_ord_flag defFlag "fhistory-size"
       (intSuffix (\n d -> d { historySize = n }))
   , make_ord_flag defFlag "funfolding-creation-threshold"
@@ -3311,6 +3518,8 @@ dynamic_flags_deps = [
                                                     d { safeInfer = False }))
   , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))
   , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))
+  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIC))
+  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIC))
 
          ------ Debugging flags ----------------------------------------------
   , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)
@@ -3323,10 +3532,7 @@ dynamic_flags_deps = [
  ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps
  ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps
  ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps
- ++ map (mkFlag turnOn  "Werror="   (\flag -> do {
-                                       ; setWarningFlag flag
-                                       ; setFatalWarningFlag flag }))
-                                                        wWarningFlagsDeps
+ ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     wWarningFlagsDeps
  ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )
                                                         wWarningFlagsDeps
  ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )
@@ -3338,6 +3544,12 @@ dynamic_flags_deps = [
  ++ [ (NotDeprecated, unrecognisedWarning "W"),
       (Deprecated,    unrecognisedWarning "fwarn-"),
       (Deprecated,    unrecognisedWarning "fno-warn-") ]
+ ++ [ make_ord_flag defFlag "Werror=compat"
+        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))
+    , make_ord_flag defFlag "Wno-error=compat"
+        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))
+    , make_ord_flag defFlag "Wwarn=compat"
+        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]
  ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps
  ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps
  ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps
@@ -3563,8 +3775,6 @@ wWarningFlagsDeps = [
 -- Please keep the list of flags below sorted alphabetically
   flagSpec "alternative-layout-rule-transitional"
                                       Opt_WarnAlternativeLayoutRuleTransitional,
-  depFlagSpec "amp"                      Opt_WarnAMP
-    "it has no effect",
   depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans
     "it has no effect",
   flagSpec "cpp-undef"                   Opt_WarnCPPUndef,
@@ -3584,7 +3794,9 @@ wWarningFlagsDeps = [
   flagSpec "redundant-constraints"       Opt_WarnRedundantConstraints,
   flagSpec "duplicate-exports"           Opt_WarnDuplicateExports,
   flagSpec "hi-shadowing"                Opt_WarnHiShadows,
+  flagSpec "inaccessible-code"           Opt_WarnInaccessibleCode,
   flagSpec "implicit-prelude"            Opt_WarnImplicitPrelude,
+  flagSpec "implicit-kind-vars"          Opt_WarnImplicitKindVars,
   flagSpec "incomplete-patterns"         Opt_WarnIncompletePatterns,
   flagSpec "incomplete-record-updates"   Opt_WarnIncompletePatternsRecUpd,
   flagSpec "incomplete-uni-patterns"     Opt_WarnIncompleteUniPatterns,
@@ -3592,6 +3804,7 @@ wWarningFlagsDeps = [
   flagSpec "identities"                  Opt_WarnIdentities,
   flagSpec "missing-fields"              Opt_WarnMissingFields,
   flagSpec "missing-import-lists"        Opt_WarnMissingImportList,
+  flagSpec "missing-export-lists"        Opt_WarnMissingExportList,
   depFlagSpec "missing-local-sigs"       Opt_WarnMissingLocalSignatures
     "it is replaced by -Wmissing-local-signatures",
   flagSpec "missing-local-signatures"    Opt_WarnMissingLocalSignatures,
@@ -3644,7 +3857,10 @@ wWarningFlagsDeps = [
                                     Opt_WarnMissingPatternSynonymSignatures,
   flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,
   flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,
-  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags ]
+  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,
+  flagSpec "star-binder"                 Opt_WarnStarBinder,
+  flagSpec "star-is-type"                Opt_WarnStarIsType,
+  flagSpec "partial-fields"              Opt_WarnPartialFields ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]
@@ -3661,14 +3877,17 @@ dFlagsDeps = [
   depFlagSpec' "ppr-ticks"              Opt_PprShowTicks
      (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),
   flagSpec "suppress-ticks"             Opt_SuppressTicks,
+  flagSpec "suppress-stg-free-vars"     Opt_SuppressStgFreeVars,
   flagSpec "suppress-coercions"         Opt_SuppressCoercions,
   flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,
   flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,
   flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,
+  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,
   flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,
   flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,
   flagSpec "suppress-uniques"           Opt_SuppressUniques,
-  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds]
+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds
+  ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
 fFlags :: [FlagSpec GeneralFlag]
@@ -3679,10 +3898,12 @@ fFlagsDeps = [
 -- See Note [Updating flag description in the User's Guide]
 -- See Note [Supporting CLI completion]
 -- Please keep the list of flags below sorted alphabetically
+  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,
   flagGhciSpec "break-on-error"               Opt_BreakOnError,
   flagGhciSpec "break-on-exception"           Opt_BreakOnException,
   flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,
   flagSpec "call-arity"                       Opt_CallArity,
+  flagSpec "exitification"                    Opt_Exitification,
   flagSpec "case-merge"                       Opt_CaseMerge,
   flagSpec "case-folding"                     Opt_CaseFolding,
   flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,
@@ -3705,15 +3926,20 @@ fFlagsDeps = [
   flagSpec "error-spans"                      Opt_ErrorSpans,
   flagSpec "excess-precision"                 Opt_ExcessPrecision,
   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,
+  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,
   flagSpec "external-interpreter"             Opt_ExternalInterpreter,
   flagSpec "flat-cache"                       Opt_FlatCache,
   flagSpec "float-in"                         Opt_FloatIn,
   flagSpec "force-recomp"                     Opt_ForceRecomp,
+  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,
+  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,
   flagSpec "full-laziness"                    Opt_FullLaziness,
   flagSpec "fun-to-thunk"                     Opt_FunToThunk,
   flagSpec "gen-manifest"                     Opt_GenManifest,
   flagSpec "ghci-history"                     Opt_GhciHistory,
+  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,
   flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,
+  flagGhciSpec "no-it"                        Opt_NoIt,
   flagSpec "ghci-sandbox"                     Opt_GhciSandbox,
   flagSpec "helpful-errors"                   Opt_HelpfulErrors,
   flagSpec "hpc"                              Opt_Hpc,
@@ -3724,8 +3950,9 @@ fFlagsDeps = [
   flagSpec "kill-absence"                     Opt_KillAbsence,
   flagSpec "kill-one-shot"                    Opt_KillOneShot,
   flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,
+  flagSpec "late-specialise"                  Opt_LateSpecialise,
   flagSpec "liberate-case"                    Opt_LiberateCase,
-  flagHiddenSpec "llvm-pass-vectors-in-regs"  Opt_LlvmPassVectorsInRegisters,
+  flagSpec "llvm-pass-vectors-in-regs"        Opt_LlvmPassVectorsInRegisters,
   flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,
   flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,
   flagSpec "loopification"                    Opt_Loopification,
@@ -3767,17 +3994,43 @@ fFlagsDeps = [
   flagSpec "write-interface"                  Opt_WriteInterface,
   flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,
   flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,
-  flagSpec "vectorisation-avoidance"          Opt_VectorisationAvoidance,
-  flagSpec "vectorise"                        Opt_Vectorise,
   flagSpec "version-macros"                   Opt_VersionMacros,
   flagSpec "worker-wrapper"                   Opt_WorkerWrapper,
   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,
   flagSpec "catch-bottoms"                    Opt_CatchBottoms,
+  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,
+  flagSpec "num-constant-folding"             Opt_NumConstantFolding,
   flagSpec "show-warning-groups"              Opt_ShowWarnGroups,
   flagSpec "hide-source-paths"                Opt_HideSourcePaths,
-  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,
+  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,
   flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs
   ]
+  ++ fHoleFlags
+
+-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or
+-- the valid hole fits in that message. See Note [Valid hole fits include ...]
+-- in the TcHoleErrors module. These flags can all be reversed with
+-- @-fno-\<blah\>@
+fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]
+fHoleFlags = [
+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,
+  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits
+   (useInstead "-f" "show-valid-hole-fits"),
+  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,
+  -- Sorting settings
+  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,
+  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,
+  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,
+  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,
+  -- Output format settings
+  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,
+  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,
+  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,
+  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,
+  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,
+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,
+  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits
+  ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
 fLangFlags :: [FlagSpec LangExt.Extension]
@@ -3810,10 +4063,6 @@ fLangFlagsDeps = [
     (deprecatedForExtension "ImplicitParams"),
   depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables
     (deprecatedForExtension "ScopedTypeVariables"),
-  depFlagSpec' "parr"                           LangExt.ParallelArrays
-    (deprecatedForExtension "ParallelArrays"),
-  depFlagSpec' "PArr"                           LangExt.ParallelArrays
-    (deprecatedForExtension "ParallelArrays"),
   depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances
     (deprecatedForExtension "OverlappingInstances"),
   depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances
@@ -3870,7 +4119,10 @@ xFlagsDeps = [
   flagSpec "AlternativeLayoutRuleTransitional"
                                               LangExt.AlternativeLayoutRuleTransitional,
   flagSpec "Arrows"                           LangExt.Arrows,
-  flagSpec "AutoDeriveTypeable"               LangExt.AutoDeriveTypeable,
+  depFlagSpecCond "AutoDeriveTypeable"        LangExt.AutoDeriveTypeable
+    id
+         ("Typeable instances are created automatically " ++
+                     "for all types since GHC 8.2."),
   flagSpec "BangPatterns"                     LangExt.BangPatterns,
   flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,
   flagSpec "CApiFFI"                          LangExt.CApiFFI,
@@ -3891,13 +4143,16 @@ xFlagsDeps = [
   flagSpec "DeriveLift"                       LangExt.DeriveLift,
   flagSpec "DeriveTraversable"                LangExt.DeriveTraversable,
   flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,
+  flagSpec "DerivingVia"                      LangExt.DerivingVia,
   flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,
   flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,
+  flagSpec "BlockArguments"                   LangExt.BlockArguments,
   depFlagSpec' "DoRec"                        LangExt.RecursiveDo
     (deprecatedForExtension "RecursiveDo"),
   flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,
   flagSpec "EmptyCase"                        LangExt.EmptyCase,
   flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,
+  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,
   flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,
   flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,
   flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,
@@ -3911,6 +4166,8 @@ xFlagsDeps = [
   flagSpec "GHCForeignImportPrim"             LangExt.GHCForeignImportPrim,
   flagSpec' "GeneralizedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving
                                               setGenDeriving,
+  flagSpec' "GeneralisedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving
+                                              setGenDeriving,
   flagSpec "ImplicitParams"                   LangExt.ImplicitParams,
   flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,
   flagSpec "ImpredicativeTypes"               LangExt.ImpredicativeTypes,
@@ -3934,10 +4191,12 @@ xFlagsDeps = [
   flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,
   flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,
   flagSpec "MultiWayIf"                       LangExt.MultiWayIf,
+  flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,
   flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,
   flagSpec "NamedFieldPuns"                   LangExt.RecordPuns,
   flagSpec "NamedWildCards"                   LangExt.NamedWildCards,
   flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,
+  flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,
   flagSpec "NondecreasingIndentation"         LangExt.NondecreasingIndentation,
   depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses
     (deprecatedForExtension "MultiParamTypeClasses"),
@@ -3958,6 +4217,7 @@ xFlagsDeps = [
   flagSpec "PatternSynonyms"                  LangExt.PatternSynonyms,
   flagSpec "PolyKinds"                        LangExt.PolyKinds,
   flagSpec "PolymorphicComponents"            LangExt.RankNTypes,
+  flagSpec "QuantifiedConstraints"            LangExt.QuantifiedConstraints,
   flagSpec "PostfixOperators"                 LangExt.PostfixOperators,
   flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,
   flagSpec "Rank2Types"                       LangExt.RankNTypes,
@@ -3974,6 +4234,7 @@ xFlagsDeps = [
   flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,
   flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,
   flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,
+  flagSpec "StarIsType"                       LangExt.StarIsType,
   flagSpec "StaticPointers"                   LangExt.StaticPointers,
   flagSpec "Strict"                           LangExt.Strict,
   flagSpec "StrictData"                       LangExt.StrictData,
@@ -4016,7 +4277,8 @@ defaultFlags settings
       Opt_RPath,
       Opt_SharedImplib,
       Opt_SimplPreInlining,
-      Opt_VersionMacros
+      Opt_VersionMacros,
+      Opt_LlvmPassVectorsInRegisters
     ]
 
     ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
@@ -4025,9 +4287,33 @@ defaultFlags settings
     ++ default_PIC platform
 
     ++ concatMap (wayGeneralFlags platform) (defaultWays settings)
+    ++ validHoleFitDefaults
 
     where platform = sTargetPlatform settings
 
+-- | These are the default settings for the display and sorting of valid hole
+--  fits in typed-hole error messages. See Note [Valid hole fits include ...]
+ -- in the TcHoleErrors module.
+validHoleFitDefaults :: [GeneralFlag]
+validHoleFitDefaults
+  =  [ Opt_ShowTypeAppOfHoleFits
+     , Opt_ShowTypeOfHoleFits
+     , Opt_ShowProvOfHoleFits
+     , Opt_ShowMatchesOfHoleFits
+     , Opt_ShowValidHoleFits
+     , Opt_SortValidHoleFits
+     , Opt_SortBySizeHoleFits
+     , Opt_ShowHoleConstraints ]
+
+
+validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
+validHoleFitsImpliedGFlags
+  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)
+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)
+    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]
+
 default_PIC :: Platform -> [GeneralFlag]
 default_PIC platform =
   case (platformOS platform, platformArch platform) of
@@ -4046,7 +4332,7 @@ impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
 impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)
                 ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)
                 ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)
-                ]
+                ] ++ validHoleFitsImpliedGFlags
 
 -- General flags that are switched on/off when other general flags are switched
 -- off
@@ -4057,6 +4343,7 @@ impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
 impliedXFlags
 -- See Note [Updating flag description in the User's Guide]
   = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)
+    , (LangExt.QuantifiedConstraints,     turnOn, LangExt.ExplicitForAll)
     , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)
     , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)
     , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
@@ -4067,12 +4354,16 @@ impliedXFlags
 
     , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!
 
+    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)
+
     , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)
     , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)
     , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)
 
     , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures
     , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds
+
+    -- TypeInType is now just a synonym for a couple of other extensions.
     , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)
     , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)
     , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)
@@ -4107,19 +4398,27 @@ impliedXFlags
     , (LangExt.Strict, turnOn, LangExt.StrictData)
   ]
 
+-- Note [When is StarIsType enabled]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The StarIsType extension determines whether to treat '*' as a regular type
+-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType
+-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is
+-- enabled.
+--
+-- Programs that use TypeOperators might expect to repurpose '*' for
+-- multiplication or another binary operation, but making TypeOperators imply
+-- NoStarIsType caused too much breakage on Hackage.
+--
+
 -- Note [Documenting optimisation flags]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
 -- If you change the list of flags enabled for particular optimisation levels
--- please remember to update the User's Guide. The relevant files are:
+-- please remember to update the User's Guide. The relevant file is:
 --
---  * utils/mkUserGuidePart/Options/
---  * docs/users_guide/using.rst
+--   docs/users_guide/using-optimisation.rst
 --
--- The first contains the Flag Reference section, which briefly lists all
--- available flags. The second contains a detailed description of the
--- flags. Both places should contain information whether a flag is implied by
--- -O0, -O or -O2.
+-- Make sure to note whether a flag is implied by -O0, -O or -O2.
 
 optLevelFlags :: [([Int], GeneralFlag)]
 optLevelFlags -- see Note [Documenting optimisation flags]
@@ -4127,19 +4426,16 @@ optLevelFlags -- see Note [Documenting optimisation flags]
     , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]
     , ([0,1,2], Opt_DmdTxDictSel)
     , ([0,1,2], Opt_LlvmTBAA)
-    , ([0,1,2], Opt_VectorisationAvoidance)
-                -- This one is important for a tiresome reason:
-                -- we want to make sure that the bindings for data
-                -- constructors are eta-expanded.  This is probably
-                -- a good thing anyway, but it seems fragile.
 
     , ([0],     Opt_IgnoreInterfacePragmas)
     , ([0],     Opt_OmitInterfacePragmas)
 
     , ([1,2],   Opt_CallArity)
+    , ([1,2],   Opt_Exitification)
     , ([1,2],   Opt_CaseMerge)
     , ([1,2],   Opt_CaseFolding)
     , ([1,2],   Opt_CmmElimCommonBlocks)
+    , ([2],     Opt_AsmShortcutting)
     , ([1,2],   Opt_CmmSink)
     , ([1,2],   Opt_CSE)
     , ([1,2],   Opt_StgCSE)
@@ -4156,6 +4452,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
     , ([1,2],   Opt_CprAnal)
     , ([1,2],   Opt_WorkerWrapper)
     , ([1,2],   Opt_SolveConstantDicts)
+    , ([1,2],   Opt_NumConstantFolding)
 
     , ([2],     Opt_LiberateCase)
     , ([2],     Opt_SpecConstr)
@@ -4189,8 +4486,7 @@ removes an assertion failure. -}
 -- If you change the list of warning enabled by default
 -- please remember to update the User's Guide. The relevant file is:
 --
---  * utils/mkUserGuidePart/
---  * docs/users_guide/using-warnings.rst
+--  docs/users_guide/using-warnings.rst
 
 -- | Warning groups.
 --
@@ -4261,7 +4557,9 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnUnsupportedLlvmVersion,
         Opt_WarnTabs,
         Opt_WarnUnrecognisedWarningFlags,
-        Opt_WarnSimplifiableClassConstraints
+        Opt_WarnSimplifiableClassConstraints,
+        Opt_WarnStarBinder,
+        Opt_WarnInaccessibleCode
       ]
 
 -- | Things you get with -W
@@ -4309,6 +4607,7 @@ minusWcompatOpts
     = [ Opt_WarnMissingMonadFailInstances
       , Opt_WarnSemigroup
       , Opt_WarnNonCanonicalMonoidInstances
+      , Opt_WarnImplicitKindVars
       ]
 
 enableUnusedBinds :: DynP ()
@@ -4332,6 +4631,7 @@ disableGlasgowExts :: DynP ()
 disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls
                         mapM_ unSetExtensionFlag glasgowExtsFlags
 
+-- Please keep what_glasgow_exts_does.rst up to date with this list
 glasgowExtsFlags :: [LangExt.Extension]
 glasgowExtsFlags = [
              LangExt.ConstrainedClassMethods
@@ -4514,6 +4814,11 @@ setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()
 setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)
 unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)
 
+setWErrorFlag :: WarningFlag -> DynP ()
+setWErrorFlag flag =
+  do { setWarningFlag flag
+     ; setFatalWarningFlag flag }
+
 --------------------------
 setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()
 setExtensionFlag f = upd (setExtensionFlag' f)
@@ -4669,6 +4974,12 @@ canonicalizeHomeModule dflags mod_name =
         Nothing  -> mkModule (thisPackage dflags) mod_name
         Just mod -> mod
 
+canonicalizeModuleIfHome :: DynFlags -> Module -> Module
+canonicalizeModuleIfHome dflags mod
+    = if thisPackage dflags == moduleUnitId mod
+                      then canonicalizeHomeModule dflags (moduleName mod)
+                      else mod
+
 
 -- -----------------------------------------------------------------------------
 -- | Find the package environment (if one exists)
@@ -4702,12 +5013,14 @@ interpretPackageEnv :: DynFlags -> IO DynFlags
 interpretPackageEnv dflags = do
     mPkgEnv <- runMaybeT $ msum $ [
                    getCmdLineArg >>= \env -> msum [
-                       probeEnvFile env
+                       probeNullEnv env
+                     , probeEnvFile env
                      , probeEnvName env
                      , cmdLineError env
                      ]
                  , getEnvVar >>= \env -> msum [
-                       probeEnvFile env
+                       probeNullEnv env
+                     , probeEnvFile env
                      , probeEnvName env
                      , envError     env
                      ]
@@ -4720,8 +5033,14 @@ interpretPackageEnv dflags = do
       Nothing ->
         -- No environment found. Leave DynFlags unchanged.
         return dflags
+      Just "-" -> do
+        -- Explicitly disabled environment file. Leave DynFlags unchanged.
+        return dflags
       Just envfile -> do
         content <- readFile envfile
+        putLogMsg dflags NoReason SevInfo noSrcSpan
+             (defaultUserStyle dflags)
+             (text ("Loaded package environment from " ++ envfile))
         let setFlags :: DynP ()
             setFlags = do
               setGeneralFlag Opt_HideAllPackages
@@ -4746,6 +5065,10 @@ interpretPackageEnv dflags = do
       guard =<< liftMaybeT (doesFileExist path)
       return path
 
+    probeNullEnv :: FilePath -> MaybeT IO FilePath
+    probeNullEnv "-" = return "-"
+    probeNullEnv _   = mzero
+
     parseEnvFile :: FilePath -> String -> DynP ()
     parseEnvFile envfile = mapM_ parseEntry . lines
       where
@@ -4856,17 +5179,6 @@ checkOptLevel n dflags
    | otherwise
      = Right dflags
 
--- -Odph is equivalent to
---
---    -O2                               optimise as much as possible
---    -fmax-simplifier-iterations20     this is necessary sometimes
---    -fsimplifier-phases=3             we use an additional simplifier phase for fusion
---
-setDPHOpt :: DynFlags -> DynP DynFlags
-setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
-                                         , simplPhases         = 3
-                                         })
-
 setMainIs :: String -> DynP ()
 setMainIs arg
   | not (null main_fn) && isLower (head main_fn)
@@ -4898,7 +5210,8 @@ addLibraryPath p =
   upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
 
 addIncludePath p =
-  upd (\s -> s{includePaths = includePaths s ++ splitPathList p})
+  upd (\s -> s{includePaths =
+                  addGlobalInclude (includePaths s) (splitPathList p)})
 
 addFrameworkPath p =
   upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})
@@ -4998,8 +5311,10 @@ setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}
 -- platform.
 
 picCCOpts :: DynFlags -> [String]
-picCCOpts dflags
-    = case platformOS (targetPlatform dflags) of
+picCCOpts dflags = pieOpts ++ picOpts
+  where
+    picOpts =
+      case platformOS (targetPlatform dflags) of
       OSDarwin
           -- Apple prefers to do things the other way round.
           -- PIC is on by default.
@@ -5024,6 +5339,23 @@ picCCOpts dflags
           ["-fPIC", "-U__PIC__", "-D__PIC__"]
        | otherwise                             -> []
 
+    pieOpts
+      | gopt Opt_PICExecutable dflags       = ["-pie"]
+        -- See Note [No PIE when linking]
+      | sGccSupportsNoPie (settings dflags) = ["-no-pie"]
+      | otherwise                           = []
+
+
+{-
+Note [No PIE while linking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by
+default in their gcc builds. This is incompatible with -r as it implies that we
+are producing an executable. Consequently, we must manually pass -no-pie to gcc
+when joining object files or linking dynamic libraries. Unless, of course, the
+user has explicitly requested a PIE executable with -pie. See #12759.
+-}
+
 picPOpts :: DynFlags -> [String]
 picPOpts dflags
  | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]
@@ -5047,7 +5379,8 @@ compilerInfo dflags
       -- Next come the settings, so anything else can be overridden
       -- in the settings file (as "lookup" uses the first match for the
       -- key)
-    : rawSettings dflags
+    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))
+          (rawSettings dflags)
    ++ [("Project version",             projectVersion dflags),
        ("Project Git commit id",       cProjectGitCommitId),
        ("Booter version",              cBooterVersion),
@@ -5098,6 +5431,8 @@ compilerInfo dflags
     showBool True  = "YES"
     showBool False = "NO"
     isWindows = platformOS (targetPlatform dflags) == OSMinGW32
+    expandDirectories :: FilePath -> Maybe FilePath -> String -> String
+    expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd
 
 -- Produced by deriveConstants
 #include "GHCConstantsHaskellWrappers.hs"
@@ -5194,6 +5529,9 @@ makeDynFlagsConsistent dflags
       = let dflags' = dflags { hscTarget = HscLlvm }
             warn = "No native code generator, so using LLVM"
         in loop dflags' warn
+ | not (osElfTarget os) && gopt Opt_PIE dflags
+    = loop (gopt_unset dflags Opt_PIE)
+           "Position-independent only supported on ELF platforms"
  | os == OSDarwin &&
    arch == ArchX86_64 &&
    not (gopt Opt_PIC dflags)
@@ -5234,9 +5572,11 @@ makeDynFlagsConsistent dflags
 -- initialized.
 defaultGlobalDynFlags :: DynFlags
 defaultGlobalDynFlags =
-    (defaultDynFlags settings) { verbosity = 2 }
+    (defaultDynFlags settings (llvmTargets, llvmPasses)) { verbosity = 2 }
   where
-    settings = panic "v_unsafeGlobalDynFlags: not initialised"
+    settings = panic "v_unsafeGlobalDynFlags: settings not initialised"
+    llvmTargets = panic "v_unsafeGlobalDynFlags: llvmTargets not initialised"
+    llvmPasses = panic "v_unsafeGlobalDynFlags: llvmPasses not initialised"
 
 #if STAGE < 2
 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags)
@@ -5307,12 +5647,32 @@ isAvx512pfEnabled :: DynFlags -> Bool
 isAvx512pfEnabled dflags = avx512pf dflags
 
 -- -----------------------------------------------------------------------------
+-- BMI2
+
+data BmiVersion = BMI1
+                | BMI2
+                deriving (Eq, Ord)
+
+isBmiEnabled :: DynFlags -> Bool
+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI1
+    ArchX86    -> bmiVersion dflags >= Just BMI1
+    _          -> False
+
+isBmi2Enabled :: DynFlags -> Bool
+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of
+    ArchX86_64 -> bmiVersion dflags >= Just BMI2
+    ArchX86    -> bmiVersion dflags >= Just BMI2
+    _          -> False
+
+-- -----------------------------------------------------------------------------
 -- Linker/compiler information
 
 -- LinkerInfo contains any extra options needed by the system linker.
 data LinkerInfo
   = GnuLD    [Option]
   | GnuGold  [Option]
+  | LlvmLLD  [Option]
   | DarwinLD [Option]
   | SolarisLD [Option]
   | AixLD    [Option]
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 5fd80fcd82..823fd22854 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -1,17 +1,20 @@
-
 module DynFlags where
 
+import GhcPrelude
 import Platform
 
 data DynFlags
 data DumpFlag
+data GeneralFlag
 
-targetPlatform       :: DynFlags -> Platform
-pprUserLength        :: DynFlags -> Int
-pprCols              :: DynFlags -> Int
-unsafeGlobalDynFlags :: DynFlags
-useUnicode           :: DynFlags -> Bool
-useUnicodeSyntax     :: DynFlags -> Bool
-shouldUseColor       :: DynFlags -> Bool
-hasPprDebug          :: DynFlags -> Bool
-hasNoDebugOutput     :: DynFlags -> Bool
+targetPlatform           :: DynFlags -> Platform
+pprUserLength            :: DynFlags -> Int
+pprCols                  :: DynFlags -> Int
+unsafeGlobalDynFlags     :: DynFlags
+useUnicode               :: DynFlags -> Bool
+useUnicodeSyntax         :: DynFlags -> Bool
+useStarIsType            :: DynFlags -> Bool
+shouldUseColor           :: DynFlags -> Bool
+shouldUseHexWordLiterals :: DynFlags -> Bool
+hasPprDebug              :: DynFlags -> Bool
+hasNoDebugOutput         :: DynFlags -> Bool
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index ffdce28762..764bf2dd41 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -2,9 +2,9 @@
 
 -- | Dynamically lookup up values from modules and loading them.
 module DynamicLoading (
+        initializePlugins,
 #if defined(GHCI)
         -- * Loading plugins
-        loadPlugins,
         loadFrontendPlugin,
 
         -- * Force loading information
@@ -20,10 +20,14 @@ module DynamicLoading (
         getHValueSafely,
         lessUnsafeCoerce
 #else
-        pluginError,
+        pluginError
 #endif
     ) where
 
+import GhcPrelude
+import HscTypes         ( HscEnv )
+import DynFlags
+
 #if defined(GHCI)
 import Linker           ( linkModule, getHValue )
 import GHCi             ( wormhole )
@@ -36,8 +40,7 @@ import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)
                         , gre_name, mkRdrQual )
 import OccName          ( OccName, mkVarOcc )
 import RnNames          ( gresFromAvails )
-import DynFlags
-import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )
+import Plugins
 import PrelNames        ( pluginTyConName, frontendPluginTyConName )
 
 import HscTypes
@@ -54,6 +57,7 @@ import Outputable
 import Exception
 import Hooks
 
+import Control.Monad     ( when, unless )
 import Data.Maybe        ( mapMaybe )
 import GHC.Exts          ( unsafeCoerce# )
 
@@ -63,31 +67,67 @@ import Module           ( ModuleName, moduleNameString )
 import Panic
 
 import Data.List        ( intercalate )
+import Control.Monad    ( unless )
+
+#endif
 
+-- | Loads the plugins specified in the pluginModNames field of the dynamic
+-- flags. Should be called after command line arguments are parsed, but before
+-- actual compilation starts. Idempotent operation. Should be re-called if
+-- pluginModNames or pluginModNameOpts changes.
+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
+initializePlugins hsc_env df
+#if !defined(GHCI)
+  = do let pluginMods = pluginModNames df
+       unless (null pluginMods) (pluginError pluginMods)
+       return df
+#else
+  | map lpModuleName (plugins df) == pluginModNames df -- plugins not changed
+     && all (\p -> lpArguments p == argumentsForPlugin p (pluginModNameOpts df))
+            (plugins df) -- arguments not changed
+  = return df -- no need to reload plugins
+  | otherwise
+  = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
+       return $ df { plugins = loadedPlugins }
+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
 #endif
 
+
 #if defined(GHCI)
 
-loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
+loadPlugins :: HscEnv -> IO [LoadedPlugin]
 loadPlugins hsc_env
-  = do { plugins <- mapM (loadPlugin hsc_env) to_load
+  = do { unless (null to_load) $
+           checkExternalInterpreter hsc_env
+       ; plugins <- mapM loadPlugin to_load
        ; return $ zipWith attachOptions to_load plugins }
   where
     dflags  = hsc_dflags hsc_env
     to_load = pluginModNames dflags
 
-    attachOptions mod_nm plug = (mod_nm, plug, options)
+    attachOptions mod_nm (plug, mod) = LoadedPlugin plug mod (reverse options)
       where
         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
                             , opt_mod_nm == mod_nm ]
+    loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env
 
-loadPlugin :: HscEnv -> ModuleName -> IO Plugin
-loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName
 
 loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
-loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+loadFrontendPlugin hsc_env mod_name = do
+    checkExternalInterpreter hsc_env
+    fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+                hsc_env mod_name
+
+-- #14335
+checkExternalInterpreter :: HscEnv -> IO ()
+checkExternalInterpreter hsc_env =
+    when (gopt Opt_ExternalInterpreter dflags) $
+      throwCmdLineError $ showSDoc dflags $
+        text "Plugins require -fno-external-interpreter"
+  where
+    dflags = hsc_dflags hsc_env
 
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
 loadPlugin' occ_name plugin_name hsc_env mod_name
   = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
              dflags = hsc_dflags hsc_env
@@ -99,7 +139,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
                           [ text "The module", ppr mod_name
                           , text "did not export the plugin name"
                           , ppr plugin_rdr_name ]) ;
-            Just name ->
+            Just (name, mod_iface) ->
 
      do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
         ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
@@ -109,7 +149,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name
                           [ text "The value", ppr name
                           , text "did not have the type"
                           , ppr pluginTyConName, text "as required"])
-            Just plugin -> return plugin } } }
+            Just plugin -> return (plugin, mod_iface) } } }
 
 
 -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
@@ -216,7 +256,10 @@ lessUnsafeCoerce dflags context what = do
 -- loaded very partially: just enough that it can be used, without its
 -- rules and instances affecting (and being linked from!) the module
 -- being compiled.  This was introduced by 57d6798.
-lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
+--
+-- Need the module as well to record information in the interface file
+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
+                                -> IO (Maybe (Name, ModIface))
 lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
     -- First find the package the module resides in by searching exposed packages and home modules
     found_module <- findPluginModule hsc_env mod_name
@@ -234,7 +277,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
                         imp_spec = ImpSpec decl_spec ImpAll
                         env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
                     case lookupGRE_RdrName rdr_name env of
-                        [gre] -> return (Just (gre_name gre))
+                        [gre] -> return (Just (gre_name gre, iface))
                         []    -> return Nothing
                         _     -> panic "lookupRdrNameInModule"
 
diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs
index 599d4d9160..648f20aad9 100644
--- a/compiler/main/Elf.hs
+++ b/compiler/main/Elf.hs
@@ -14,6 +14,8 @@ module Elf (
     makeElfNote
   ) where
 
+import GhcPrelude
+
 import AsmUtils
 import Exception
 import DynFlags
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 5883fe14da..c7fb8babe9 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -10,7 +10,7 @@
 
 module ErrUtils (
         -- * Basic types
-        Validity(..), andValid, allValid, isValid, getInvalids,
+        Validity(..), andValid, allValid, isValid, getInvalids, orValid,
         Severity(..),
 
         -- * Messages
@@ -57,6 +57,8 @@ module ErrUtils (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Bag
 import Exception
 import Outputable
@@ -108,6 +110,10 @@ allValid (v : vs) = v `andValid` allValid vs
 getInvalids :: [Validity] -> [MsgDoc]
 getInvalids vs = [d | NotValid d <- vs]
 
+orValid :: Validity -> Validity -> Validity
+orValid IsValid _ = IsValid
+orValid _       v = v
+
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
 
@@ -450,6 +456,29 @@ mkDumpDoc hdr doc
      where
         line = text (replicate 20 '=')
 
+-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
+-- file, otherwise 'Nothing'.
+withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
+withDumpFileHandle dflags flag action = do
+    let mFile = chooseDumpFile dflags flag
+    case mFile of
+      Just fileName -> do
+        let gdref = generatedDumps dflags
+        gd <- readIORef gdref
+        let append = Set.member fileName gd
+            mode = if append then AppendMode else WriteMode
+        unless append $
+            writeIORef gdref (Set.insert fileName gd)
+        createDirectoryIfMissing True (takeDirectory fileName)
+        withFile fileName mode $ \handle -> do
+            -- We do not want the dump file to be affected by
+            -- environment variables, but instead to always use
+            -- UTF8. See:
+            -- https://ghc.haskell.org/trac/ghc/ticket/10762
+            hSetEncoding handle utf8
+
+            action (Just handle)
+      Nothing -> action Nothing
 
 -- | Write out a dump.
 -- If --dump-to-file is set then this goes to a file.
@@ -461,43 +490,31 @@ mkDumpDoc hdr doc
 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
 -- is used; it is not used to decide whether to dump the output
 dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDoc dflags print_unqual flag hdr doc
- = do let mFile = chooseDumpFile dflags flag
-          dump_style = mkDumpStyle dflags print_unqual
-      case mFile of
-            Just fileName
-                 -> do
-                        let gdref = generatedDumps dflags
-                        gd <- readIORef gdref
-                        let append = Set.member fileName gd
-                            mode = if append then AppendMode else WriteMode
-                        unless append $
-                            writeIORef gdref (Set.insert fileName gd)
-                        createDirectoryIfMissing True (takeDirectory fileName)
-                        handle <- openFile fileName mode
-
-                        -- We do not want the dump file to be affected by
-                        -- environment variables, but instead to always use
-                        -- UTF8. See:
-                        -- https://ghc.haskell.org/trac/ghc/ticket/10762
-                        hSetEncoding handle utf8
-
-                        doc' <- if null hdr
-                                then return doc
-                                else do t <- getCurrentTime
-                                        let d = text (show t)
-                                             $$ blankLine
-                                             $$ doc
-                                        return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' dump_style
-                        hClose handle
-
-            -- write the dump to stdout
-            Nothing -> do
-              let (doc', severity)
-                    | null hdr  = (doc, SevOutput)
-                    | otherwise = (mkDumpDoc hdr doc, SevDump)
-              putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
+dumpSDoc dflags print_unqual flag hdr doc =
+    withDumpFileHandle dflags flag writeDump
+  where
+    dump_style = mkDumpStyle dflags print_unqual
+
+    -- write dump to file
+    writeDump (Just handle) = do
+        doc' <- if null hdr
+                then return doc
+                else do t <- getCurrentTime
+                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
+                                          then empty
+                                          else text (show t)
+                        let d = timeStamp
+                                $$ blankLine
+                                $$ doc
+                        return $ mkDumpDoc hdr d
+        defaultLogActionHPrintDoc dflags handle doc' dump_style
+
+    -- write the dump to stdout
+    writeDump Nothing = do
+        let (doc', severity)
+              | null hdr  = (doc, SevOutput)
+              | otherwise = (mkDumpDoc hdr doc, SevDump)
+        putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -608,7 +625,7 @@ withTiming :: MonadIO m
            -> m a
 withTiming getDFlags what force_result action
   = do dflags <- getDFlags
-       if verbosity dflags >= 2
+       if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
           then do liftIO $ logInfo dflags (defaultUserStyle dflags)
                          $ text "***" <+> what <> colon
                   alloc0 <- liftIO getAllocationCounter
@@ -619,14 +636,24 @@ withTiming getDFlags what force_result action
                   alloc1 <- liftIO getAllocationCounter
                   -- recall that allocation counter counts down
                   let alloc = alloc0 - alloc1
-                  liftIO $ logInfo dflags (defaultUserStyle dflags)
-                      (text "!!!" <+> what <> colon <+> text "finished in"
-                       <+> doublePrec 2 (realToFrac (end - start) * 1e-9)
-                       <+> text "milliseconds"
-                       <> comma
-                       <+> text "allocated"
-                       <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
-                       <+> text "megabytes")
+                      time = realToFrac (end - start) * 1e-9
+
+                  when (verbosity dflags >= 2)
+                      $ liftIO $ logInfo dflags (defaultUserStyle dflags)
+                          (text "!!!" <+> what <> colon <+> text "finished in"
+                           <+> doublePrec 2 time
+                           <+> text "milliseconds"
+                           <> comma
+                           <+> text "allocated"
+                           <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
+                           <+> text "megabytes")
+
+                  liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings ""
+                      $ text $ showSDocOneLine dflags
+                      $ hsep [ what <> colon
+                             , text "alloc=" <> ppr alloc
+                             , text "time=" <> doublePrec 3 time
+                             ]
                   pure r
            else action
 
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index bbbf74e197..6f180af546 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -1,5 +1,6 @@
 module ErrUtils where
 
+import GhcPrelude
 import Outputable (SDoc, PrintUnqualified )
 import SrcLoc (SrcSpan)
 import Json
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs
index f4c30d6112..35bed6149b 100644
--- a/compiler/main/FileCleanup.hs
+++ b/compiler/main/FileCleanup.hs
@@ -3,9 +3,12 @@ module FileCleanup
   ( TempFileLifetime(..)
   , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
   , addFilesToClean, changeTempFilesLifetime
-  , newTempName, newTempLibName
+  , newTempName, newTempLibName, newTempDir
+  , withSystemTempDirectory, withTempDirectory
   ) where
 
+import GhcPrelude
+
 import DynFlags
 import ErrUtils
 import Outputable
@@ -129,6 +132,21 @@ newTempName dflags lifetime extn
                         addFilesToClean dflags lifetime [filename]
                         return filename
 
+newTempDir :: DynFlags -> IO FilePath
+newTempDir dflags
+  = do d <- getTempDir dflags
+       findTempDir (d </> "ghc_")
+  where
+    findTempDir :: FilePath -> IO FilePath
+    findTempDir prefix
+      = do n <- newTempSuffix dflags
+           let filename = prefix ++ show n
+           b <- doesDirectoryExist filename
+           if b then findTempDir prefix
+                else do createDirectory filename
+                        -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename
+                        return filename
+
 newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
   -> IO (FilePath, FilePath, String)
 newTempLibName dflags lifetime extn
@@ -247,3 +265,50 @@ foreign import ccall unsafe "_getpid" getProcessID :: IO Int
 getProcessID :: IO Int
 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 #endif
+
+-- The following three functions are from the `temporary` package.
+
+-- | Create and use a temporary directory in the system standard temporary
+-- directory.
+--
+-- Behaves exactly the same as 'withTempDirectory', except that the parent
+-- temporary directory will be that returned by 'getTemporaryDirectory'.
+withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.
+                        -> (FilePath -> IO a) -- ^ Callback that can use the directory
+                        -> IO a
+withSystemTempDirectory template action =
+  getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action
+
+
+-- | Create and use a temporary directory.
+--
+-- Creates a new temporary directory inside the given directory, making use
+-- of the template. The temp directory is deleted after use. For example:
+--
+-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...
+--
+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
+-- @src/sdist.342@.
+withTempDirectory :: FilePath -- ^ Temp directory to create the directory in
+                  -> String   -- ^ Directory name template. See 'openTempFile'.
+                  -> (FilePath -> IO a) -- ^ Callback that can use the directory
+                  -> IO a
+withTempDirectory targetDir template =
+  Exception.bracket
+    (createTempDirectory targetDir template)
+    (ignoringIOErrors . removeDirectoryRecursive)
+
+ignoringIOErrors :: IO () -> IO ()
+ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))
+
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+  pid <- getProcessID
+  findTempName pid
+  where findTempName x = do
+            let path = dir </> template ++ show x
+            createDirectory path
+            return path
+          `catchIO` \e -> if isAlreadyExistsError e
+                          then findTempName (x+1) else ioError e
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index d1bf1c8073..9a3cb6009b 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -33,6 +33,8 @@ module Finder (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Module
 import HscTypes
 import Packages
@@ -150,15 +152,17 @@ orIfNotFound this or_this = do
   res <- this
   case res of
     NotFound { fr_paths = paths1, fr_mods_hidden = mh1
-             , fr_pkgs_hidden = ph1, fr_suggestions = s1 }
+             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
      -> do res2 <- or_this
            case res2 of
              NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
-                      , fr_pkgs_hidden = ph2, fr_suggestions = s2 }
+                      , fr_pkgs_hidden = ph2, fr_unusables = u2
+                      , fr_suggestions = s2 }
               -> return (NotFound { fr_paths = paths1 ++ paths2
                                   , fr_pkg = mb_pkg2 -- snd arg is the package search
                                   , fr_mods_hidden = mh1 ++ mh2
                                   , fr_pkgs_hidden = ph1 ++ ph2
+                                  , fr_unusables = u1 ++ u2
                                   , fr_suggestions = s1  ++ s2 })
              _other -> return res2
     _other -> return res
@@ -203,6 +207,7 @@ findLookupResult hsc_env r = case r of
         InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
                                          , fr_pkgs_hidden = []
                                          , fr_mods_hidden = []
+                                         , fr_unusables = []
                                          , fr_suggestions = []})
      LookupMultiple rs ->
        return (FoundMultiple rs)
@@ -210,11 +215,23 @@ findLookupResult hsc_env r = case r of
        return (NotFound{ fr_paths = [], fr_pkg = Nothing
                        , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
                        , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
+                       , fr_unusables = []
                        , fr_suggestions = [] })
+     LookupUnusable unusable ->
+       let unusables' = map get_unusable unusable
+           get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
+           get_unusable (_, r)             =
+             pprPanic "findLookupResult: unexpected origin" (ppr r)
+       in return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                          , fr_pkgs_hidden = []
+                          , fr_mods_hidden = []
+                          , fr_unusables = unusables'
+                          , fr_suggestions = [] })
      LookupNotFound suggest ->
        return (NotFound{ fr_paths = [], fr_pkg = Nothing
                        , fr_pkgs_hidden = []
                        , fr_mods_hidden = []
+                       , fr_unusables = []
                        , fr_suggestions = suggest })
 
 modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
@@ -258,6 +275,7 @@ findHomeModule hsc_env mod_name = do
         fr_pkg = Just uid,
         fr_mods_hidden = [],
         fr_pkgs_hidden = [],
+        fr_unusables = [],
         fr_suggestions = []
       }
  where
@@ -568,8 +586,19 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
 -- Error messages
 
 cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
-cannotFindModule = cantFindErr (sLit "Could not find module")
-                               (sLit "Ambiguous module name")
+cannotFindModule flags mod res =
+  cantFindErr (sLit cannotFindMsg)
+              (sLit "Ambiguous module name")
+              flags mod res
+  where
+    cannotFindMsg =
+      case res of
+        NotFound { fr_mods_hidden = hidden_mods
+                 , fr_pkgs_hidden = hidden_pkgs
+                 , fr_unusables = unusables }
+          | not (null hidden_mods && null hidden_pkgs && null unusables)
+          -> "Could not load module"
+        _ -> "Could not find module"
 
 cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc
 cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
@@ -596,6 +625,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
     pprMod (m, o) = text "it is bound as" <+> ppr m <+>
                                 text "by" <+> pprOrigin m o
     pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
     pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
       if e == Just True
           then [text "package" <+> ppr (moduleUnitId m)]
@@ -617,20 +647,22 @@ cantFindErr cannot_find _ dflags mod_name find_result
 
             NotFound { fr_paths = files, fr_pkg = mb_pkg
                      , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
-                     , fr_suggestions = suggest }
+                     , fr_unusables = unusables, fr_suggestions = suggest }
                 | Just pkg <- mb_pkg, pkg /= thisPackage dflags
                 -> not_found_in_package pkg files
 
                 | not (null suggest)
-                -> pp_suggestions suggest $$ tried_these files
+                -> pp_suggestions suggest $$ tried_these files dflags
 
-                | null files && null mod_hiddens && null pkg_hiddens
+                | null files && null mod_hiddens &&
+                  null pkg_hiddens && null unusables
                 -> text "It is not a module in the current program, or in any known package."
 
                 | otherwise
                 -> vcat (map pkg_hidden pkg_hiddens) $$
                    vcat (map mod_hidden mod_hiddens) $$
-                   tried_these files
+                   vcat (map unusable unusables) $$
+                   tried_these files dflags
 
             _ -> panic "cantFindErr"
 
@@ -644,20 +676,13 @@ cantFindErr cannot_find _ dflags mod_name find_result
          in
          text "Perhaps you haven't installed the " <> text build <>
          text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
-         tried_these files
+         tried_these files dflags
 
        | otherwise
        = text "There are files missing in the " <> quotes (ppr pkg) <>
          text " package," $$
          text "try running 'ghc-pkg check'." $$
-         tried_these files
-
-    tried_these files
-        | null files = Outputable.empty
-        | verbosity dflags < 3 =
-              text "Use -v to see a list of the files searched for."
-        | otherwise =
-               hang (text "Locations searched:") 2 $ vcat (map text files)
+         tried_these files dflags
 
     pkg_hidden :: UnitId -> SDoc
     pkg_hidden pkgid =
@@ -665,18 +690,28 @@ cantFindErr cannot_find _ dflags mod_name find_result
         <+> quotes (ppr pkgid)
         --FIXME: we don't really want to show the unit id here we should
         -- show the source package id or installed package id if it's ambiguous
-        <> dot $$ cabal_pkg_hidden_hint pkgid
-    cabal_pkg_hidden_hint pkgid
+        <> dot $$ pkg_hidden_hint pkgid
+    pkg_hidden_hint pkgid
      | gopt Opt_BuildingCabalPackage dflags
         = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)
            in text "Perhaps you need to add" <+>
               quotes (ppr (packageName pkg)) <+>
               text "to the build-depends in your .cabal file."
+     | Just pkg <- lookupPackage dflags pkgid
+         = text "You can run" <+>
+           quotes (text ":set -package " <> ppr (packageName pkg)) <+>
+           text "to expose it." $$
+           text "(Note: this unloads all the modules in the current scope.)"
      | otherwise = Outputable.empty
 
     mod_hidden pkg =
         text "it is a hidden module in the package" <+> quotes (ppr pkg)
 
+    unusable (pkg, reason)
+      = text "It is a member of the package"
+      <+> quotes (ppr pkg)
+      $$ pprReason (text "which is") reason
+
     pp_suggestions :: [ModuleSuggestion] -> SDoc
     pp_suggestions sugs
       | null sugs = Outputable.empty
@@ -688,6 +723,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
     -- also has a reexport, prefer that one
     pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
       where provenance ModHidden = Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
             provenance (ModOrigin{ fromOrigPackage = e,
                                    fromExposedReexport = res,
                                    fromPackageFlag = f })
@@ -704,6 +740,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
               | otherwise = Outputable.empty
     pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
       where provenance ModHidden =  Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
             provenance (ModOrigin{ fromOrigPackage = e,
                                    fromHiddenReexport = rhs })
               | Just False <- e
@@ -734,7 +771,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
                 -> text "It is not a module in the current program, or in any known package."
 
                 | otherwise
-                -> tried_these files
+                -> tried_these files dflags
 
             _ -> panic "cantFindInstalledErr"
 
@@ -760,17 +797,19 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
          in
          text "Perhaps you haven't installed the " <> text build <>
          text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
-         tried_these files
+         tried_these files dflags
 
        | otherwise
        = text "There are files missing in the " <> quotes (ppr pkg) <>
          text " package," $$
          text "try running 'ghc-pkg check'." $$
-         tried_these files
-
-    tried_these files
-        | null files = Outputable.empty
-        | verbosity dflags < 3 =
-              text "Use -v to see a list of the files searched for."
-        | otherwise =
-               hang (text "Locations searched:") 2 $ vcat (map text files)
+         tried_these files dflags
+
+tried_these :: [FilePath] -> DynFlags -> SDoc
+tried_these files dflags
+    | null files = Outputable.empty
+    | verbosity dflags < 3 =
+          text "Use -v (or `:set -v` in ghci) " <>
+              text "to see a list of the files searched for."
+    | otherwise =
+          hang (text "Locations searched:") 2 $ vcat (map text files)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 3ca07f1443..cf9c74f885 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -132,6 +132,9 @@ module GHC (
         ForeignHValue,
         compileExprRemote, compileParsedExprRemote,
 
+        -- ** Docs
+        getDocs, GetDocsFailure(..),
+
         -- ** Other
         runTcInteractive,   -- Desired by some clients (Trac #8878)
         isStmt, hasImport, isImport, isDecl,
@@ -283,6 +286,8 @@ module GHC (
 
 #include "HsVersions.h"
 
+import GhcPrelude hiding (init)
+
 import ByteCodeTypes
 import InteractiveEval
 import InteractiveEvalTypes
@@ -295,7 +300,8 @@ import HscMain
 import GhcMake
 import DriverPipeline   ( compileOne' )
 import GhcMonad
-import TcRnMonad        ( finalSafeMode, fixSafeInstances )
+import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import LoadIface        ( loadSysInterface )
 import TcRnTypes
 import Packages
 import NameSet
@@ -321,6 +327,7 @@ import HscTypes
 import CmdLineParser
 import DynFlags hiding (WarnReason(..))
 import SysTools
+import SysTools.BaseDir
 import Annotations
 import Module
 import Panic
@@ -361,8 +368,6 @@ import System.Exit      ( exitWith, ExitCode(..) )
 import Exception
 import Data.IORef
 import System.FilePath
-import System.IO
-import Prelude hiding (init)
 
 
 -- %************************************************************************
@@ -472,7 +477,6 @@ withCleanupSession ghc = ghc `gfinally` cleanup
           cleanTempFiles dflags
           cleanTempDirs dflags
           stopIServ hsc_env -- shut down the IServ
-          log_finaliser dflags dflags
           --  exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
           -- signals.
@@ -492,8 +496,10 @@ withCleanupSession ghc = ghc `gfinally` cleanup
 initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
 initGhcMonad mb_top_dir
   = do { env <- liftIO $
-                do { mySettings <- initSysTools mb_top_dir
-                   ; dflags <- initDynFlags (defaultDynFlags mySettings)
+                do { top_dir <- findTopDir mb_top_dir
+                   ; mySettings <- initSysTools top_dir
+                   ; myLlvmConfig <- initLlvmConfig top_dir
+                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
                    ; checkBrokenTablesNextToCode dflags
                    ; setUnsafeGlobalDynFlags dflags
                       -- c.f. DynFlags.parseDynamicFlagsFull, which
@@ -591,12 +597,11 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags
 -- | Set the action taken when the compiler produces a message.  This
 -- can also be accomplished using 'setProgramDynFlags', but using
 -- 'setLogAction' avoids invalidating the cached module graph.
-setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m ()
-setLogAction action finaliser = do
+setLogAction :: GhcMonad m => LogAction -> m ()
+setLogAction action = do
   dflags' <- getProgramDynFlags
   void $ setProgramDynFlags_ False $
-    dflags' { log_action = action
-            , log_finaliser = finaliser }
+    dflags' { log_action = action }
 
 setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
 setProgramDynFlags_ invalidate_needed dflags = do
@@ -672,6 +677,8 @@ checkNewDynFlags dflags = do
 
 checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
 checkNewInteractiveDynFlags dflags0 = do
+  -- We currently don't support use of StaticPointers in expressions entered on
+  -- the REPL. See #12356.
   dflags1 <-
       if xopt LangExt.StaticPointers dflags0
       then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
@@ -847,7 +854,7 @@ instance DesugaredMod DesugaredModule where
   coreModule m = dm_core_module m
 
 type ParsedSource      = Located (HsModule GhcPs)
-type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn],
+type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
                           Maybe LHsDocString)
 type TypecheckedSource = LHsBinds GhcTc
 
@@ -1031,16 +1038,19 @@ compileCore simplify fn = do
      Just modSummary -> do
        -- Now we have the module name;
        -- parse, typecheck and desugar the module
-       mod_guts <- coreModule `fmap`
-                      -- TODO: space leaky: call hsc* directly?
-                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
+       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
+         do tm <- typecheckModule =<< parseModule modSummary
+            let tcg = fst (tm_internals tm)
+            (,) tcg . coreModule <$> desugarModule tm
        liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
          if simplify
           then do
              -- If simplify is true: simplify (hscSimplify), then tidy
              -- (tidyProgram).
              hsc_env <- getSession
-             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
+             simpl_guts <- liftIO $ do
+               plugins <- readIORef (tcg_th_coreplugins tcg)
+               hscSimplify hsc_env plugins mod_guts
              tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
              return $ Left tidy_guts
           else
@@ -1240,12 +1250,22 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
 -- by 'Name'. Each name's lists will contain every instance in which that name
 -- is mentioned in the instance head.
 getNameToInstancesIndex :: GhcMonad m
-  => m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
-getNameToInstancesIndex = do
+  => [Module]        -- ^ visible modules. An orphan instance will be returned
+                     -- if it is visible from at least one module in the list.
+  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
+                     -- modules for everything that is in scope unqualified.
+  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
+getNameToInstancesIndex visible_mods mods_to_load = do
   hsc_env <- getSession
   liftIO $ runTcInteractive hsc_env $
-    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
-       ; InstEnvs {ie_global, ie_local, ie_visible} <- tcGetInstEnvs
+    do { case mods_to_load of
+           Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+           Just mods ->
+             let doc = text "Need interface for reporting instances in scope"
+             in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
+
+       ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
+       ; let visible_mods' = mkModuleSet visible_mods
        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
        -- We use Data.Sequence.Seq because we are creating left associated
        -- mappends.
@@ -1253,7 +1273,7 @@ getNameToInstancesIndex = do
        ; let cls_index = Map.fromListWith mappend
                  [ (n, Seq.singleton ispec)
                  | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
-                 , instIsVisible ie_visible ispec
+                 , instIsVisible visible_mods' ispec
                  , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
                  ]
        ; let fam_index = Map.fromListWith mappend
@@ -1301,7 +1321,6 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
 
 -- ----------------------------------------------------------------------------
 
-#if 0
 
 -- ToDo:
 --   - Data and Typeable instances for HsSyn.
@@ -1315,7 +1334,6 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
 -- :browse will use either lm_toplev or inspect lm_interface, depending
 -- on whether the module is interpreted or not.
 
-#endif
 
 -- Extract the filename, stringbuffer content and dynflags associed to a module
 --
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index f4a9a319ac..39b6427173 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -33,6 +33,8 @@ module GhcMake(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import qualified Linker         ( unload )
 
 import DriverPhases
@@ -199,11 +201,16 @@ warnMissingHomeModules hsc_env mod_graph =
 
     msg
       | gopt Opt_BuildingCabalPackage dflags
-      = text "These modules are needed for compilation but not listed in your .cabal file's other-modules: "
-        <> sep (map ppr missing)
+      = hang
+          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
+          4
+          (sep (map ppr missing))
       | otherwise
-      = text "Modules are not listed in command line but needed for compilation: "
-        <> sep (map ppr missing)
+      =
+        hang
+          (text "Modules are not listed in command line but needed for compilation: ")
+          4
+          (sep (map ppr missing))
     warn = makeIntoWarning
       (Reason Opt_WarnMissingHomeModules)
       (mkPlainErrMsg dflags noSrcSpan msg)
@@ -703,7 +710,7 @@ checkStability
         -> StableModules
 
 checkStability hpt sccs all_home_mods =
-  foldl checkSCC (emptyUniqSet, emptyUniqSet) sccs
+  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs
   where
    checkSCC :: StableModules -> SCC ModSummary -> StableModules
    checkSCC (stable_obj, stable_bco) scc0
@@ -1172,7 +1179,13 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
                                     Just (ms_mod lcl_mod, type_env_var) }
                 lcl_hsc_env'' <- case finish_loop of
                     Nothing   -> return lcl_hsc_env'
+                    -- In the non-parallel case, the retypecheck prior to
+                    -- typechecking the loop closer includes all modules
+                    -- EXCEPT the loop closer.  However, our precomputed
+                    -- SCCs include the loop closer, so we have to filter
+                    -- it out.
                     Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
+                                 filter (/= moduleName (fst this_build_mod)) $
                                  map (moduleName . fst) loop
 
                 -- Compile the module.
@@ -1195,8 +1208,10 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup
                     let hsc_env' = hsc_env
                                      { hsc_HPT = addToHpt (hsc_HPT hsc_env)
                                                            this_mod mod_info }
-                    -- If this module is a loop finisher, now is the time to
-                    -- re-typecheck the loop.
+                    -- We've finished typechecking the module, now we must
+                    -- retypecheck the loop AGAIN to ensure unfoldings are
+                    -- updated.  This time, however, we include the loop
+                    -- closer!
                     hsc_env'' <- case finish_loop of
                         Nothing   -> return hsc_env'
                         Just loop -> typecheckLoop lcl_dflags hsc_env' $
@@ -1672,6 +1687,42 @@ reTypecheckLoop hsc_env ms graph
   mss = mgModSummaries graph
   appearsAsBoot = (`elemModuleSet` mgBootModules graph)
 
+-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
+-- corresponding boot file in @graph@, return the set of modules which
+-- transitively depend on this boot file.  This function is slightly misnamed,
+-- but its name "getModLoop" alludes to the fact that, when getModLoop is called
+-- with a graph that does not contain @ms@ (non-parallel case) or is an
+-- SCC with hs-boot nodes dropped (parallel-case), the modules which
+-- depend on the hs-boot file are typically (but not always) the
+-- modules participating in the recursive module loop.  The returned
+-- list includes the hs-boot file.
+--
+-- Example:
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
+--
+--      It would also be permissible to omit A.hs from the graph,
+--      in which case the result is [A.hs-boot, B.hs]
+--
+-- Example:
+--      A counter-example to the claim that modules returned
+--      by this function participate in the loop occurs here:
+--
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--          D.hs imports A.hs-boot
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
+--
+--      Arguably, D.hs should import A.hs, not A.hs-boot, but
+--      a dependency on the boot file is not illegal.
+--
 getModLoop
   :: ModSummary
   -> [ModSummary]
@@ -1687,6 +1738,8 @@ getModLoop ms graph appearsAsBoot
  where
   this_mod = ms_mod ms
 
+-- NB: sometimes mods has duplicates; this is harmless because
+-- any duplicates get clobbered in addListToHpt and never get forced.
 typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
 typecheckLoop dflags hsc_env mods = do
   debugTraceMsg dflags 2 $
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 2673dd8e45..f72cacc7ef 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -23,6 +23,8 @@ module GhcMonad (
         WarnErrLogger, defaultWarnErrLogger
   ) where
 
+import GhcPrelude
+
 import MonadUtils
 import HscTypes
 import DynFlags
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
index c064c0e833..3e0facf97b 100644
--- a/compiler/main/GhcPlugins.hs
+++ b/compiler/main/GhcPlugins.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
 
 -- | This module is not used by GHC itself.  Rather, it exports all of
 -- the functions and types you are likely to need when writing a
@@ -19,7 +19,10 @@ module GhcPlugins(
         module VarSet, module VarEnv, module NameSet, module NameEnv,
         module UniqSet, module UniqFM, module FiniteMap,
         module Util, module GHC.Serialized, module SrcLoc, module Outputable,
-        module UniqSupply, module Unique, module FastString
+        module UniqSupply, module Unique, module FastString,
+
+        -- * Getting 'Name's
+        thNameToGhcName
     ) where
 
 -- Plugin stuff itself
@@ -82,3 +85,48 @@ import Outputable
 import UniqSupply
 import Unique           ( Unique, Uniquable(..) )
 import FastString
+import Data.Maybe
+
+import NameCache (lookupOrigNameCache)
+import GhcPrelude
+import MonadUtils       ( mapMaybeM )
+import Convert          ( thRdrNameGuesses )
+import TcEnv            ( lookupGlobal )
+
+import qualified Language.Haskell.TH as TH
+
+{- This instance is defined outside CoreMonad.hs so that
+   CoreMonad does not depend on TcEnv -}
+instance MonadThings CoreM where
+    lookupThing name = do { hsc_env <- getHscEnv
+                          ; liftIO $ lookupGlobal hsc_env name }
+
+{-
+************************************************************************
+*                                                                      *
+               Template Haskell interoperability
+*                                                                      *
+************************************************************************
+-}
+
+-- | Attempt to convert a Template Haskell name to one that GHC can
+-- understand. Original TH names such as those you get when you use
+-- the @'foo@ syntax will be translated to their equivalent GHC name
+-- exactly. Qualified or unqualified TH names will be dynamically bound
+-- to names in the module being compiled, if possible. Exact TH names
+-- will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference
+          -- to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+      = return $ if isExternalName n then Just n else Nothing
+      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+      = do { cache <- getOrigNameCache
+           ; return $ lookupOrigNameCache cache rdr_mod rdr_occ }
+      | otherwise = return Nothing
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index be38e53f3d..127cc6d911 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -18,6 +18,8 @@ module HeaderInfo ( getImports
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HscTypes
 import Parser           ( parseHeader )
 import Lexer
@@ -120,7 +122,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 
       preludeImportDecl :: LImportDecl GhcPs
       preludeImportDecl
-        = L loc $ ImportDecl { ideclSourceSrc = NoSourceText,
+        = L loc $ ImportDecl { ideclExt       = noExt,
+                               ideclSourceSrc = NoSourceText,
                                ideclName      = L loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = False,
@@ -241,7 +244,8 @@ getOptions' dflags toks
               | IToptions_prag str <- getToken open
               , ITclose_prag       <- getToken close
               = case toArgs str of
-                  Left err -> panic ("getOptions'.parseToks: " ++ err)
+                  Left _err -> optionsParseError str dflags $   -- #15053
+                                 combineSrcSpans (getLoc open) (getLoc close)
                   Right args -> map (L (getLoc open)) args ++ parseToks xs
           parseToks (open:close:xs)
               | ITinclude_prag str <- getToken open
@@ -311,17 +315,15 @@ checkExtension dflags (L l ext)
 
 languagePragParseError :: DynFlags -> SrcSpan -> a
 languagePragParseError dflags loc =
-  throw $ mkSrcErr $ unitBag $
-     (mkPlainErrMsg dflags loc $
+    throwErr dflags loc $
        vcat [ text "Cannot parse LANGUAGE pragma"
             , text "Expecting comma-separated list of language options,"
             , text "each starting with a capital letter"
-            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ])
+            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
 
 unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
 unsupportedExtnError dflags loc unsup =
-  throw $ mkSrcErr $ unitBag $
-    mkPlainErrMsg dflags loc $
+    throwErr dflags loc $
         text "Unsupported extension: " <> text unsup $$
         if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
   where
@@ -337,3 +339,14 @@ optionsErrorMsgs dflags unhandled_flags flags_lines _filename
             ErrUtils.mkPlainErrMsg dflags flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
 
+optionsParseError :: String -> DynFlags -> SrcSpan -> a     -- #15053
+optionsParseError str dflags loc =
+  throwErr dflags loc $
+      vcat [ text "Error while parsing OPTIONS_GHC pragma."
+           , text "Expecting whitespace-separated list of GHC options."
+           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
+           , text ("Input was: " ++ show str) ]
+
+throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053
+throwErr dflags loc doc =
+  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index 59126e98d5..f9d420ab61 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -2,8 +2,6 @@
 
 -- NB: this module is SOURCE-imported by DynFlags, and should primarily
 --     refer to *types*, rather than *code*
--- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES
--- stuff in compiler/ghc.mk makes DynFlags link to too much stuff
 
 {-# LANGUAGE CPP #-}
 module Hooks ( Hooks
@@ -25,6 +23,8 @@ module Hooks ( Hooks
              , createIservProcessHook
              ) where
 
+import GhcPrelude
+
 import DynFlags
 import PipelineMonad
 import HscTypes
diff --git a/compiler/main/Hooks.hs-boot b/compiler/main/Hooks.hs-boot
index 280de32063..f0246ef941 100644
--- a/compiler/main/Hooks.hs-boot
+++ b/compiler/main/Hooks.hs-boot
@@ -1,5 +1,7 @@
 module Hooks where
 
+import GhcPrelude ()
+
 data Hooks
 
 emptyHooks :: Hooks
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index c514e5b017..a8a33bfaad 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -82,7 +82,10 @@ module HscMain
     , hscAddSptEntries
     ) where
 
+import GhcPrelude
+
 import Data.Data hiding (Fixity, TyCon)
+import DynFlags         (addPluginModuleName)
 import Id
 import GHCi             ( addSptEntry )
 import GHCi.RemoteTypes ( ForeignHValue )
@@ -138,6 +141,8 @@ import Fingerprint      ( Fingerprint )
 import Hooks
 import TcEnv
 import PrelNames
+import Plugins
+import DynamicLoading   ( initializePlugins )
 
 import DynFlags
 import ErrUtils
@@ -340,7 +345,7 @@ hscParse' mod_summary
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
                                    ppr rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
-                                   text (showAstData NoBlankSrcSpan rdr_module)
+                                   showAstData NoBlankSrcSpan rdr_module
             liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
                                    ppSourceStats False rdr_module
 
@@ -358,7 +363,7 @@ hscParse' mod_summary
                 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
                             $ filter (not . (== n_hspp))
                             $ map FilePath.normalise
-                            $ filter (not . (isPrefixOf "<"))
+                            $ filter (not . isPrefixOf "<")
                             $ map unpackFS
                             $ srcfiles pst
                 srcs1 = case ml_hs_file (ms_location mod_summary) of
@@ -370,7 +375,7 @@ hscParse' mod_summary
             -- filter them out:
             srcs2 <- liftIO $ filterM doesFileExist srcs1
 
-            return HsParsedModule {
+            let res = HsParsedModule {
                       hpm_module    = rdr_module,
                       hpm_src_files = srcs2,
                       hpm_annotations
@@ -379,32 +384,46 @@ hscParse' mod_summary
                                                  :(annotations_comments pst)))
                    }
 
--- XXX: should this really be a Maybe X?  Check under which circumstances this
--- can become a Nothing and decide whether this should instead throw an
--- exception/signal an error.
-type RenamedStuff =
-        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn],
-                Maybe LHsDocString))
+            -- apply parse transformation of plugins
+            let applyPluginAction p opts
+                  = parsedResultAction p opts mod_summary
+            withPlugins dflags applyPluginAction res
+
+
+-- -----------------------------------------------------------------------------
+-- | If the renamed source has been kept, extract it. Dump it if requested.
+extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff)
+extract_renamed_stuff tc_result = do
+    let rn_info = getRenamedStuff tc_result
+
+    dflags <- getDynFlags
+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
+                           showAstData NoBlankSrcSpan rn_info
+
+    return (tc_result, rn_info)
+
 
+-- -----------------------------------------------------------------------------
 -- | Rename and typecheck a module, additionally returning the renamed syntax
 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                    -> IO (TcGblEnv, RenamedStuff)
 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
-    tc_result <- hscTypecheck True mod_summary (Just rdr_module)
-
-        -- This 'do' is in the Maybe monad!
-    let rn_info = do decl <- tcg_rn_decls tc_result
-                     let imports = tcg_rn_imports tc_result
-                         exports = tcg_rn_exports tc_result
-                         doc_hdr = tcg_doc_hdr tc_result
-                     return (decl,imports,exports,doc_hdr)
-
-    return (tc_result, rn_info)
+      tc_result <- hscTypecheck True mod_summary (Just rdr_module)
+      extract_renamed_stuff tc_result
 
 hscTypecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
              -> Hsc TcGblEnv
 hscTypecheck keep_rn mod_summary mb_rdr_module = do
+    tc_result <- hscTypecheck' keep_rn mod_summary mb_rdr_module
+    _ <- extract_renamed_stuff tc_result
+    return tc_result
+
+
+hscTypecheck' :: Bool -- ^ Keep renamed source?
+              -> ModSummary -> Maybe HsParsedModule
+              -> Hsc TcGblEnv
+hscTypecheck' keep_rn mod_summary mb_rdr_module = do
     hsc_env <- getHscEnv
     let hsc_src = ms_hsc_src mod_summary
         dflags = hsc_dflags hsc_env
@@ -421,7 +440,7 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do
          do hpm <- case mb_rdr_module of
                     Just hpm -> return hpm
                     Nothing -> hscParse' mod_summary
-            tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm
+            tc_result0 <- tcRnModule' mod_summary keep_rn hpm
             if hsc_src == HsigFile
                 then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
                         ioMsgMaybe $
@@ -429,42 +448,51 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do
                 else return tc_result0
 
 -- wrapper around tcRnModule to handle safe haskell extras
-tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule
+tcRnModule' :: ModSummary -> Bool -> HsParsedModule
             -> Hsc TcGblEnv
-tcRnModule' hsc_env sum save_rn_syntax mod = do
+tcRnModule' sum save_rn_syntax mod = do
+    hsc_env <- getHscEnv
+    dflags   <- getDynFlags
+
     tcg_res <- {-# SCC "Typecheck-Rename" #-}
                ioMsgMaybe $
-                   tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod
+                   tcRnModule hsc_env sum
+                     save_rn_syntax mod
 
     -- See Note [Safe Haskell Overlapping Instances Implementation]
     -- although this is used for more than just that failure case.
     (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
-    dflags   <- getDynFlags
     let allSafeOK = safeInferred dflags && tcSafeOK
 
     -- 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 markUnsafeInfer tcg_res whyUnsafe
-
-        -- module (could be) safe, throw warning if needed
-        else do
-            tcg_res' <- hscCheckSafeImports tcg_res
-            safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
-            when safe $ do
-              case wopt Opt_WarnSafe dflags of
-                True -> (logWarnings $ unitBag $
-                         makeIntoWarning (Reason Opt_WarnSafe) $
-                         mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
-                         errSafe tcg_res')
-                False | safeHaskell dflags == Sf_Trustworthy &&
-                        wopt Opt_WarnTrustworthySafe dflags ->
-                        (logWarnings $ unitBag $
-                         makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
-                         mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
-                         errTwthySafe tcg_res')
-                False -> return ()
-            return tcg_res'
+    res <- if not (safeHaskellOn dflags)
+                || (safeInferOn dflags && not allSafeOK)
+             -- if safe Haskell off or safe infer failed, mark unsafe
+             then markUnsafeInfer tcg_res whyUnsafe
+
+             -- module (could be) safe, throw warning if needed
+             else do
+                 tcg_res' <- hscCheckSafeImports tcg_res
+                 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
+                 when safe $ do
+                   case wopt Opt_WarnSafe dflags of
+                     True -> (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnSafe) $
+                              mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
+                              errSafe tcg_res')
+                     False | safeHaskell dflags == Sf_Trustworthy &&
+                             wopt Opt_WarnTrustworthySafe dflags ->
+                             (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
+                              mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
+                              errTwthySafe tcg_res')
+                     False -> return ()
+                 return tcg_res'
+
+    -- apply plugins to the type checking result
+
+
+    return res
   where
     pprMod t  = ppr $ moduleName $ tcg_mod t
     errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
@@ -506,7 +534,7 @@ makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
                    --------------------------------
 
 It's the task of the compilation proper to compile Haskell, hs-boot and core
-files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
 (the module is still parsed and type-checked. This feature is mostly used by
 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
@@ -644,15 +672,18 @@ hscIncrementalCompile :: Bool
 hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
     mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
   = do
+    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
+    let hsc_env'' = hsc_env' { hsc_dflags = dflags }
+
     -- One-shot mode needs a knot-tying mutable variable for interface
     -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
     -- See also Note [hsc_type_env_var hack]
     type_env_var <- newIORef emptyNameEnv
     let mod = ms_mod mod_summary
-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'))
-                = hsc_env' { hsc_type_env_var = Just (mod, type_env_var) }
+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
+                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
                 | otherwise
-                = hsc_env'
+                = hsc_env''
 
     -- NB: enter Hsc monad here so that we don't bail out early with
     -- -Werror on typechecker warnings; we also want to run the desugarer
@@ -687,19 +718,19 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
         -- to retypecheck but the resulting interface is exactly
         -- the same.)
         Right (FrontendTypecheck tc_result, mb_old_hash) ->
-            finish hsc_env mod_summary tc_result mb_old_hash
+            finish mod_summary tc_result mb_old_hash
 
 -- Runs the post-typechecking frontend (desugar and simplify),
 -- and then generates and writes out the final interface. We want
 -- to write the interface AFTER simplification so we can get
 -- as up-to-date and good unfoldings and other info as possible
 -- in the interface file.
-finish :: HscEnv
-       -> ModSummary
+finish :: ModSummary
        -> TcGblEnv
        -> Maybe Fingerprint
        -> Hsc (HscStatus, HomeModInfo)
-finish hsc_env summary tc_result mb_old_hash = do
+finish summary tc_result mb_old_hash = do
+  hsc_env <- getHscEnv
   let dflags = hsc_dflags hsc_env
       target = hscTarget dflags
       hsc_src = ms_hsc_src summary
@@ -728,7 +759,8 @@ finish hsc_env summary tc_result mb_old_hash = do
           -- and generate a simple interface.
           then mk_simple_iface
           else do
-            desugared_guts <- hscSimplify' desugared_guts0
+            plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+            desugared_guts <- hscSimplify' plugins desugared_guts0
             (iface, changed, details, cgguts) <-
               liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
             return (iface, changed, details, HscRecomp cgguts summary)
@@ -857,7 +889,7 @@ hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
 hscCheckSafeImports tcg_env = do
     dflags   <- getDynFlags
-    tcg_env' <- checkSafeImports dflags tcg_env
+    tcg_env' <- checkSafeImports tcg_env
     checkRULES dflags tcg_env'
 
   where
@@ -877,15 +909,16 @@ hscCheckSafeImports tcg_env = do
               -> return tcg_env'
 
     warns dflags rules = listToBag $ map (warnRules dflags) rules
-    warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
+    warnRules dflags (L loc (HsRule _ n _ _ _ _)) =
         mkPlainWarnMsg dflags loc $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
+    warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"
 
 -- | Validate that safe imported modules are actually safe.  For modules in the
 -- HomePackage (the package the module we are compiling in resides) this just
 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
--- that reside in another package we also must check that the external pacakge
+-- that reside in another package we also must check that the external package
 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
 -- information.
 --
@@ -894,9 +927,10 @@ hscCheckSafeImports tcg_env = do
 -- RnNames.rnImportDecl for where package trust dependencies for a module are
 -- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust
 -- Transitively] and the Note [RnNames . Trust Own Package].
-checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
-checkSafeImports dflags tcg_env
+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
+checkSafeImports tcg_env
     = do
+        dflags <- getDynFlags
         imps <- mapM condense imports'
         let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
 
@@ -932,8 +966,8 @@ checkSafeImports dflags tcg_env
             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
+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
             return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
 
   where
@@ -952,7 +986,9 @@ checkSafeImports dflags tcg_env
     cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
     cond' v1 v2
         | imv_is_safe v1 /= imv_is_safe v2
-        = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
+        = do
+            dflags <- getDynFlags
+            throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
               (text "Module" <+> ppr (imv_name v1) <+>
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
@@ -960,18 +996,19 @@ checkSafeImports dflags tcg_env
 
     -- easier interface to work with
     checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
-    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
 
     -- what pkg's to add to our trust requirements
-    pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails
-    pkgTrustReqs req inf infPassed | safeInferOn dflags
+    pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
+          Bool -> ImportAvails
+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
                                   && safeHaskell dflags == Sf_None && infPassed
                                    = emptyImportAvails {
                                        imp_trust_pkgs = req `S.union` inf
                                    }
-    pkgTrustReqs _   _ _ | safeHaskell dflags == Sf_Unsafe
+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe
                          = emptyImportAvails
-    pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req }
+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
 
 -- | Check that a module is safe to import.
 --
@@ -980,16 +1017,15 @@ checkSafeImports dflags tcg_env
 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
     dflags <- getDynFlags
-    pkgs <- snd `fmap` hscCheckSafe' dflags m l
-    when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
+    pkgs <- snd `fmap` hscCheckSafe' m l
+    when (packageTrustOn dflags) $ checkPkgTrust pkgs
     errs <- getWarnings
     return $ isEmptyBag errs
 
 -- | Return if a module is trusted and the pkgs it depends on to be trusted.
 hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
 hscGetSafe hsc_env m l = runHsc hsc_env $ do
-    dflags       <- getDynFlags
-    (self, pkgs) <- hscCheckSafe' dflags m l
+    (self, pkgs) <- hscCheckSafe' m l
     good         <- isEmptyBag `fmap` getWarnings
     clearWarnings -- don't want them printed...
     let pkgs' | Just p <- self = S.insert p pkgs
@@ -1000,18 +1036,21 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
 -- Return (regardless of trusted or not) if the trust type requires the modules
 -- own package be trusted and a list of other packages required to be trusted
 -- (these later ones haven't been checked) but the own package trust has been.
-hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
-hscCheckSafe' dflags m l = do
+hscCheckSafe' :: Module -> SrcSpan
+  -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
+hscCheckSafe' m l = do
+    dflags <- getDynFlags
     (tw, pkgs) <- isModSafe m l
     case tw of
-        False              -> return (Nothing, pkgs)
-        True | isHomePkg m -> return (Nothing, pkgs)
+        False                     -> return (Nothing, pkgs)
+        True | isHomePkg dflags m -> return (Nothing, pkgs)
              -- TODO: do we also have to check the trust of the instantiation?
              -- Not necessary if that is reflected in dependencies
              | otherwise   -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
   where
     isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
     isModSafe m l = do
+        dflags <- getDynFlags
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
@@ -1026,7 +1065,7 @@ hscCheckSafe' dflags m l = do
                     -- check module is trusted
                     safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
                     -- check package is trusted
-                    safeP = packageTrusted trust trust_own_pkg m
+                    safeP = packageTrusted dflags trust trust_own_pkg m
                     -- pkg trust reqs
                     pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
                     -- General errors we throw but Safe errors we log
@@ -1054,18 +1093,19 @@ hscCheckSafe' dflags m l = do
     -- modules are trusted without requiring that their package is trusted. For
     -- trustworthy modules, modules in the home package are trusted but
     -- otherwise we check the package trust flag.
-    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
-    packageTrusted Sf_None             _ _ = False -- shouldn't hit these cases
-    packageTrusted Sf_Unsafe           _ _ = False -- prefer for completeness.
-    packageTrusted _ _ _
-        | not (packageTrustOn dflags)      = True
-    packageTrusted Sf_Safe         False _ = True
-    packageTrusted _ _ m
-        | isHomePkg m = True
-        | otherwise   = trusted $ getPackageDetails dflags (moduleUnitId m)
+    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ Sf_None      _ _ = False -- shouldn't hit these cases
+    packageTrusted _ Sf_Unsafe    _ _ = False -- prefer for completeness.
+    packageTrusted dflags _ _ _
+        | not (packageTrustOn dflags) = True
+    packageTrusted _ Sf_Safe  False _ = True
+    packageTrusted dflags _ _ m
+        | isHomePkg dflags m = True
+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
 
     lookup' :: Module -> Hsc (Maybe ModIface)
     lookup' m = do
+        dflags <- getDynFlags
         hsc_env <- getHscEnv
         hsc_eps <- liftIO $ hscEPS hsc_env
         let pkgIfaceT = eps_PIT hsc_eps
@@ -1080,19 +1120,16 @@ hscCheckSafe' dflags m l = do
         return iface'
 
 
-    isHomePkg :: Module -> Bool
-    isHomePkg m
+    isHomePkg :: DynFlags -> Module -> Bool
+    isHomePkg dflags m
         | thisPackage dflags == moduleUnitId m = True
         | otherwise                               = False
 
 -- | Check the list of packages are trusted.
-checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc ()
-checkPkgTrust dflags pkgs =
-    case errors of
-        [] -> return ()
-        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
-    where
-        errors = S.foldr go [] pkgs
+checkPkgTrust :: Set InstalledUnitId -> Hsc ()
+checkPkgTrust pkgs = do
+    dflags <- getDynFlags
+    let errors = S.foldr go [] pkgs
         go pkg acc
             | trusted $ getInstalledPackageDetails dflags pkg
             = acc
@@ -1100,6 +1137,9 @@ checkPkgTrust dflags pkgs =
             = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
                      $ text "The package (" <> ppr pkg <> text ") is required" <>
                        text " to be trusted but it isn't!"
+    case errors of
+        [] -> return ()
+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
 
 -- | Set module to unsafe and (potentially) wipe trust information.
 --
@@ -1163,14 +1203,18 @@ hscGetSafeMode tcg_env = do
 -- Simplifiers
 --------------------------------------------------------------
 
-hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
-hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
+hscSimplify hsc_env plugins modguts =
+    runHsc hsc_env $ hscSimplify' plugins modguts
 
-hscSimplify' :: ModGuts -> Hsc ModGuts
-hscSimplify' ds_result = do
+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
+hscSimplify' plugins ds_result = do
     hsc_env <- getHscEnv
+    let hsc_env_with_plugins = hsc_env
+          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
+          }
     {-# SCC "Core2Core" #-}
-      liftIO $ core2core hsc_env ds_result
+      liftIO $ core2core hsc_env_with_plugins ds_result
 
 --------------------------------------------------------------
 -- Interface generators
@@ -1270,15 +1314,17 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
-        prepd_binds <- {-# SCC "CorePrep" #-}
+        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}
                        corePrepPgm hsc_env this_mod location
                                    core_binds data_tycons
         -----------------  Convert to STG ------------------
-        (stg_binds, cost_centre_info)
+        (stg_binds, (caf_ccs, caf_cc_stacks))
             <- {-# SCC "CoreToStg" #-}
                myCoreToStg dflags this_mod prepd_binds
 
-        let prof_init = profilingInitCode this_mod cost_centre_info
+        let cost_centre_info =
+              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
+            prof_init = profilingInitCode this_mod cost_centre_info
             foreign_stubs = foreign_stubs0 `appendStubC` prof_init
 
         ------------------  Code generation ------------------
@@ -1335,7 +1381,7 @@ hscInteractive hsc_env cgguts mod_summary = do
     -------------------
     -- PREPARE FOR CODE GENERATION
     -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-}
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
                    corePrepPgm hsc_env this_mod location core_binds data_tycons
     -----------------  Generate byte code ------------------
     comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
@@ -1351,15 +1397,13 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        us <- mkSplitUniqSupply 'S'
-        let initTopSRT = initUs_ us emptySRT
         dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
-        (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
-        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         let -- Make up a module name to give the NCG. We can't pass bottom here
             -- lest we reproduce #11784.
             mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
             cmm_mod = mkModule (thisPackage dflags) mod_name
+        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
              rawCmms
         return ()
@@ -1410,21 +1454,17 @@ doCodeGen hsc_env this_mod data_tycons
         osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
         = {-# SCC "cmmPipeline" #-}
           let run_pipeline us cmmgroup = do
-                let (topSRT', us') = initUs us emptySRT
-                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
-                let srt | isEmptySRT topSRT = []
-                        | otherwise         = srtToData topSRT
-                return (us', srt ++ cmmgroup)
+                (_topSRT, cmmgroup) <-
+                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup
+                return (us, cmmgroup)
 
           in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
                 return ()
 
       | otherwise
         = {-# SCC "cmmPipeline" #-}
-          let initTopSRT = initUs_ us emptySRT
-              run_pipeline = cmmPipeline hsc_env
-          in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
-                Stream.yield (srtToData topSRT)
+          let run_pipeline = cmmPipeline hsc_env
+          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
 
     let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
@@ -1439,15 +1479,15 @@ doCodeGen hsc_env this_mod data_tycons
 
 myCoreToStg :: DynFlags -> Module -> CoreProgram
             -> IO ( [StgTopBinding] -- output program
-                  , CollectedCCs) -- cost centre info (declared and used)
+                  , CollectedCCs )  -- CAF cost centre info (declared and used)
 myCoreToStg dflags this_mod prepd_binds = do
-    let stg_binds
+    let (stg_binds, cost_centre_info)
          = {-# SCC "Core2Stg" #-}
            coreToStg dflags this_mod prepd_binds
 
-    (stg_binds2, cost_centre_info)
+    stg_binds2
         <- {-# SCC "Stg2Stg" #-}
-           stg2stg dflags this_mod stg_binds
+           stg2stg dflags stg_binds
 
     return (stg_binds2, cost_centre_info)
 
@@ -1553,7 +1593,9 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
 
     {- Simplify -}
-    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
+    simpl_mg <- liftIO $ do
+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
+      hscSimplify hsc_env plugins ds_result
 
     {- Tidy -}
     (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
@@ -1571,7 +1613,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
 
     {- Prepare For Code Generation -}
     -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-}
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
       liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
 
     {- Generate byte code -}
@@ -1668,7 +1710,7 @@ hscParseExpr expr = do
   hsc_env <- getHscEnv
   maybe_stmt <- hscParseStmt expr
   case maybe_stmt of
-    Just (L _ (BodyStmt expr _ _ _)) -> return expr
+    Just (L _ (BodyStmt _ expr _ _)) -> return expr
     _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
       (text "not an expression:" <+> quotes (text expr))
 
@@ -1713,7 +1755,7 @@ hscParseThingWithLocation source linenumber parser str
             logWarningsReportErrors (getMessages pst dflags)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
-                                   text $ showAstData NoBlankSrcSpan thing
+                                   showAstData NoBlankSrcSpan thing
             return thing
 
 
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 598cb5be0a..ce59ca1877 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -8,6 +8,8 @@
 
 module HscStats ( ppSourceStats ) where
 
+import GhcPrelude
+
 import Bag
 import HsSyn
 import Outputable
@@ -68,18 +70,18 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)
 
     (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
-        = count_sigs [d | SigD d <- decls]
+        = count_sigs [d | SigD _ d <- decls]
                 -- NB: this omits fixity decls on local bindings and
                 -- in class decls. ToDo
 
-    tycl_decls = [d | TyClD d <- decls]
+    tycl_decls = [d | TyClD _ d <- decls]
     (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
       countTyClDecls tycl_decls
 
-    inst_decls = [d | InstD d <- decls]
+    inst_decls = [d | InstD _ d <- decls]
     inst_ds    = length inst_decls
     default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
-    val_decls  = [d | ValD d <- decls]
+    val_decls  = [d | ValD _ d <- decls]
 
     real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
     n_exports    = length real_exports
@@ -100,7 +102,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
         = sum5 (map inst_info inst_decls)
 
-    count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0)
+    count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
     count_bind (PatBind {})                           = (0,1,0)
     count_bind (FunBind {})                           = (0,1,0)
     count_bind (PatSynBind {})                        = (0,0,1)
@@ -118,6 +120,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
                                  , ideclAs = as, ideclHiding = spec }))
         = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    import_info (L _ (XImportDecl _)) = panic "import_info"
     safe_info = qual_info
     qual_info False  = 0
     qual_info True   = 1
@@ -153,6 +156,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                    ss, is, length ats, length adts)
       where
         methods = map unLoc $ bagToList inst_meths
+    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"
+    inst_info (XInstDecl _)                 = panic "inst_info"
 
     -- TODO: use Sum monoid
     addpr :: (Int,Int,Int) -> Int
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index e064147965..77067c2ee2 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -44,7 +44,7 @@ module HscTypes (
         lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,
         addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
         hptCompleteSigs,
-        hptInstances, hptRules, hptVectInfo, pprHPT,
+        hptInstances, hptRules, pprHPT,
 
         -- * State relating to known packages
         ExternalPackageState(..), EpsStats(..), addEpsInStats,
@@ -106,7 +106,7 @@ module HscTypes (
         -- * Information on imports and exports
         WhetherHasOrphans, IsBootInterface, Usage(..),
         Dependencies(..), noDependencies,
-        updNameCacheIO,
+        updNameCache,
         IfaceExport,
 
         -- * Warnings
@@ -123,10 +123,6 @@ module HscTypes (
         -- * Breakpoints
         ModBreaks (..), emptyModBreaks,
 
-        -- * Vectorisation information
-        VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
-        noIfaceVectInfo, isNoIfaceVectInfo,
-
         -- * Safe Haskell information
         IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
         trustInfoToNum, numToTrustInfo, IsSafeImport,
@@ -146,6 +142,8 @@ module HscTypes (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import ByteCodeTypes
 import InteractiveEvalTypes ( Resume )
 import GHCi.Message         ( Pipe )
@@ -159,11 +157,9 @@ import Avail
 import Module
 import InstEnv          ( InstEnv, ClsInst, identicalClsInstHead )
 import FamInstEnv
-import CoreSyn          ( CoreProgram, RuleBase, CoreRule, CoreVect )
+import CoreSyn          ( CoreProgram, RuleBase, CoreRule )
 import Name
 import NameEnv
-import NameSet
-import VarEnv
 import VarSet
 import Var
 import Id
@@ -178,8 +174,7 @@ import CoAxiom
 import ConLike
 import DataCon
 import PatSyn
-import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule
-                        , eqTyConName )
+import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
 import TysWiredIn
 import Packages hiding  ( Version(..) )
 import CmdLineParser
@@ -208,7 +203,6 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Foreign
 import Control.Monad    ( guard, liftM, ap )
-import Data.Foldable    ( foldl' )
 import Data.IORef
 import Data.Time
 import Exception
@@ -663,13 +657,6 @@ hptInstances hsc_env want_this_module
                 return (md_insts details, md_fam_insts details)
     in (concat insts, concat famInsts)
 
--- | Get the combined VectInfo of all modules in the home package table. In
--- contrast to instances and rules, we don't care whether the modules are
--- "below" us in the dependency sense. The VectInfo of those modules not "below"
--- us does not affect the compilation of the current module.
-hptVectInfo :: HscEnv -> VectInfo
-hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details)
-
 -- | Get rules from modules "below" this one (in the dependency sense)
 hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
 hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
@@ -828,6 +815,9 @@ data FindResult
       , fr_pkgs_hidden :: [UnitId]      -- Module is in these packages,
                                            --   but the *package* is hidden
 
+        -- Modules are in these packages, but it is unusable
+      , fr_unusables   :: [(UnitId, UnusablePackageReason)]
+
       , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules
       }
 
@@ -855,7 +845,11 @@ data ModIface
         mi_iface_hash :: !Fingerprint,        -- ^ Hash of the whole interface
         mi_mod_hash   :: !Fingerprint,        -- ^ Hash of the ABI only
         mi_flag_hash  :: !Fingerprint,        -- ^ Hash of the important flags
-                                              -- used when compiling this module
+                                              -- used when compiling the module,
+                                              -- excluding optimisation flags
+        mi_opt_hash   :: !Fingerprint,        -- ^ Hash of optimisation flags
+        mi_hpc_hash   :: !Fingerprint,        -- ^ Hash of hpc flags
+        mi_plugin_hash :: !Fingerprint,       -- ^ Hash of plugins
 
         mi_orphan     :: !WhetherHasOrphans,  -- ^ Whether this module has orphans
         mi_finsts     :: !WhetherHasFamInst,
@@ -928,9 +922,7 @@ data ModIface
         mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
         mi_rules       :: [IfaceRule],     -- ^ Sorted rules
         mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules, class and family
-                                           -- instances, and vectorise pragmas combined
-
-        mi_vect_info :: !IfaceVectInfo,    -- ^ Vectorisation information
+                                           -- instances combined
 
                 -- Cached environments for easy lookup
                 -- These are computed (lazily) from other fields
@@ -959,7 +951,16 @@ data ModIface
                 -- itself) but imports some trustworthy modules from its own
                 -- package (which does require its own package be trusted).
                 -- See Note [RnNames . Trust Own Package]
-        mi_complete_sigs :: [IfaceCompleteMatch]
+        mi_complete_sigs :: [IfaceCompleteMatch],
+
+        mi_doc_hdr :: Maybe HsDocString,
+                -- ^ Module header.
+
+        mi_decl_docs :: DeclDocMap,
+                -- ^ Docs on declarations.
+
+        mi_arg_docs :: ArgDocMap
+                -- ^ Docs on arguments.
      }
 
 -- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -1016,6 +1017,9 @@ instance Binary ModIface where
                  mi_iface_hash= iface_hash,
                  mi_mod_hash  = mod_hash,
                  mi_flag_hash = flag_hash,
+                 mi_opt_hash  = opt_hash,
+                 mi_hpc_hash  = hpc_hash,
+                 mi_plugin_hash = plugin_hash,
                  mi_orphan    = orphan,
                  mi_finsts    = hasFamInsts,
                  mi_deps      = deps,
@@ -1031,17 +1035,22 @@ instance Binary ModIface where
                  mi_fam_insts = fam_insts,
                  mi_rules     = rules,
                  mi_orphan_hash = orphan_hash,
-                 mi_vect_info = vect_info,
                  mi_hpc       = hpc_info,
                  mi_trust     = trust,
                  mi_trust_pkg = trust_pkg,
-                 mi_complete_sigs = complete_sigs }) = do
+                 mi_complete_sigs = complete_sigs,
+                 mi_doc_hdr   = doc_hdr,
+                 mi_decl_docs = decl_docs,
+                 mi_arg_docs  = arg_docs }) = do
         put_ bh mod
         put_ bh sig_of
         put_ bh hsc_src
         put_ bh iface_hash
         put_ bh mod_hash
         put_ bh flag_hash
+        put_ bh opt_hash
+        put_ bh hpc_hash
+        put_ bh plugin_hash
         put_ bh orphan
         put_ bh hasFamInsts
         lazyPut bh deps
@@ -1057,11 +1066,13 @@ instance Binary ModIface where
         put_ bh fam_insts
         lazyPut bh rules
         put_ bh orphan_hash
-        put_ bh vect_info
         put_ bh hpc_info
         put_ bh trust
         put_ bh trust_pkg
         put_ bh complete_sigs
+        lazyPut bh doc_hdr
+        lazyPut bh decl_docs
+        lazyPut bh arg_docs
 
    get bh = do
         mod         <- get bh
@@ -1070,6 +1081,9 @@ instance Binary ModIface where
         iface_hash  <- get bh
         mod_hash    <- get bh
         flag_hash   <- get bh
+        opt_hash    <- get bh
+        hpc_hash    <- get bh
+        plugin_hash <- get bh
         orphan      <- get bh
         hasFamInsts <- get bh
         deps        <- lazyGet bh
@@ -1085,11 +1099,13 @@ instance Binary ModIface where
         fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
         rules       <- {-# SCC "bin_rules" #-} lazyGet bh
         orphan_hash <- get bh
-        vect_info   <- get bh
         hpc_info    <- get bh
         trust       <- get bh
         trust_pkg   <- get bh
         complete_sigs <- get bh
+        doc_hdr     <- lazyGet bh
+        decl_docs   <- lazyGet bh
+        arg_docs    <- lazyGet bh
         return (ModIface {
                  mi_module      = mod,
                  mi_sig_of      = sig_of,
@@ -1097,6 +1113,9 @@ instance Binary ModIface where
                  mi_iface_hash  = iface_hash,
                  mi_mod_hash    = mod_hash,
                  mi_flag_hash   = flag_hash,
+                 mi_opt_hash    = opt_hash,
+                 mi_hpc_hash    = hpc_hash,
+                 mi_plugin_hash = plugin_hash,
                  mi_orphan      = orphan,
                  mi_finsts      = hasFamInsts,
                  mi_deps        = deps,
@@ -1113,7 +1132,6 @@ instance Binary ModIface where
                  mi_fam_insts   = fam_insts,
                  mi_rules       = rules,
                  mi_orphan_hash = orphan_hash,
-                 mi_vect_info   = vect_info,
                  mi_hpc         = hpc_info,
                  mi_trust       = trust,
                  mi_trust_pkg   = trust_pkg,
@@ -1121,7 +1139,10 @@ instance Binary ModIface where
                  mi_warn_fn     = mkIfaceWarnCache warns,
                  mi_fix_fn      = mkIfaceFixCache fixities,
                  mi_hash_fn     = mkIfaceHashCache decls,
-                 mi_complete_sigs = complete_sigs })
+                 mi_complete_sigs = complete_sigs,
+                 mi_doc_hdr     = doc_hdr,
+                 mi_decl_docs   = decl_docs,
+                 mi_arg_docs    = arg_docs })
 
 -- | The original names declared of a certain module that are exported
 type IfaceExport = AvailInfo
@@ -1134,6 +1155,9 @@ emptyModIface mod
                mi_iface_hash  = fingerprint0,
                mi_mod_hash    = fingerprint0,
                mi_flag_hash   = fingerprint0,
+               mi_opt_hash    = fingerprint0,
+               mi_hpc_hash    = fingerprint0,
+               mi_plugin_hash = fingerprint0,
                mi_orphan      = False,
                mi_finsts      = False,
                mi_hsc_src     = HsSrcFile,
@@ -1151,14 +1175,16 @@ emptyModIface mod
                mi_decls       = [],
                mi_globals     = Nothing,
                mi_orphan_hash = fingerprint0,
-               mi_vect_info   = noIfaceVectInfo,
                mi_warn_fn     = emptyIfaceWarnCache,
                mi_fix_fn      = emptyIfaceFixCache,
                mi_hash_fn     = emptyIfaceHashCache,
                mi_hpc         = False,
                mi_trust       = noIfaceTrustInfo,
                mi_trust_pkg   = False,
-               mi_complete_sigs = [] }
+               mi_complete_sigs = [],
+               mi_doc_hdr     = Nothing,
+               mi_decl_docs   = emptyDeclDocMap,
+               mi_arg_docs    = emptyArgDocMap }
 
 
 -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
@@ -1190,7 +1216,6 @@ data ModDetails
         md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
         md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
                                         -- they only annotate things also declared in this module
-        md_vect_info :: !VectInfo,       -- ^ Module vectorisation information
         md_complete_sigs :: [CompleteMatch]
           -- ^ Complete match pragmas for this module
      }
@@ -1204,7 +1229,6 @@ emptyModDetails
                  md_rules     = [],
                  md_fam_insts = [],
                  md_anns      = [],
-                 md_vect_info = noVectInfo,
                  md_complete_sigs = [] }
 
 -- | Records the modules directly imported by a module for extracting e.g.
@@ -1229,7 +1253,8 @@ data ImportedModsVal
         imv_span :: SrcSpan,             -- ^ the source span of the whole import
         imv_is_safe :: IsSafeImport,     -- ^ whether this is a safe import
         imv_is_hiding :: Bool,           -- ^ whether this is an "hiding" import
-        imv_all_exports :: GlobalRdrEnv, -- ^ all the things the module could provide
+        imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide
+          -- NB. BangPattern here: otherwise this leaks. (#15111)
         imv_qualified :: Bool            -- ^ whether this is a qualified import
         }
 
@@ -1263,16 +1288,13 @@ data ModGuts
                                          -- See Note [Overall plumbing for rules] in Rules.hs
         mg_binds     :: !CoreProgram,    -- ^ Bindings for this module
         mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module
-        mg_foreign_files :: ![(ForeignSrcLang, String)],
+        mg_foreign_files :: ![(ForeignSrcLang, FilePath)],
         -- ^ Files to be compiled with the C compiler
         mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
         mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
         mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module
         mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module
-        mg_vect_decls:: ![CoreVect],     -- ^ Vectorisation declarations in this module
-                                         --   (produced by desugarer & consumed by vectoriser)
-        mg_vect_info :: !VectInfo,       -- ^ Pool of vectorised declarations in the module
 
                         -- The next two fields are unusual, because they give instance
                         -- environments for *all* modules in the home package, including
@@ -1287,9 +1309,13 @@ data ModGuts
                                                 -- one); c.f. 'tcg_fam_inst_env'
 
         mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode
-        mg_trust_pkg    :: Bool                 -- ^ Do we need to trust our
+        mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our
                                                 -- own package for Safe Haskell?
                                                 -- See Note [RnNames . Trust Own Package]
+
+        mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.
+        mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.
+        mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.
     }
 
 -- The ModGuts takes on several slightly different forms:
@@ -1320,11 +1346,11 @@ data CgGuts
                 -- ^ The tidied main bindings, including
                 -- previously-implicit bindings for record and class
                 -- selectors, and data constructor wrappers.  But *not*
-                -- data constructor workers; reason: we we regard them
+                -- data constructor workers; reason: we regard them
                 -- as part of the code-gen of tycons
 
         cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs
-        cg_foreign_files :: ![(ForeignSrcLang, String)],
+        cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
         cg_dep_pkgs  :: ![InstalledUnitId], -- ^ Dependent packages, used to
                                             -- generate #includes for C code gen
         cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information
@@ -1626,7 +1652,7 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults
   = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
                             -- Always bump this; even instances should create
                             -- a new mod_index (Trac #9426)
-          , ic_tythings   = new_tythings ++ ic_tythings ictxt
+          , ic_tythings   = new_tythings ++ old_tythings
           , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings
           , ic_instances  = ( new_cls_insts ++ old_cls_insts
                             , new_fam_insts ++ fam_insts )
@@ -1636,6 +1662,8 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults
           , ic_fix_env    = fix_env  -- See Note [Fixity declarations in GHCi]
           }
   where
+    new_ids = [id | AnId id <- new_tythings]
+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)
 
     -- Discard old instances that have been fully overridden
     -- See Note [Override identical instances in GHCi]
@@ -1647,10 +1675,17 @@ extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveCont
 extendInteractiveContextWithIds ictxt new_ids
   | null new_ids = ictxt
   | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1
-                         , ic_tythings   = new_tythings ++ ic_tythings ictxt
+                         , ic_tythings   = new_tythings ++ old_tythings
                          , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }
   where
     new_tythings = map AnId new_ids
+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)
+
+shadowed_by :: [Id] -> TyThing -> Bool
+shadowed_by ids = shadowed
+  where
+    shadowed id = getOccName id `elemOccSet` new_occs
+    new_occs = mkOccSet (map getOccName ids)
 
 setInteractivePackage :: HscEnv -> HscEnv
 -- Set the 'thisPackage' DynFlag to 'interactive'
@@ -1675,7 +1710,7 @@ icExtendGblRdrEnv env tythings
        | is_sub_bndr thing
        = env
        | otherwise
-       = foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
+       = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
        where
           env1  = shadowNames env (concatMap availNames avail)
           avail = tyThingAvailInfo thing
@@ -1696,8 +1731,13 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
   | isEmptyTCvSubst subst = ictxt
   | otherwise             = ictxt { ic_tythings = map subst_ty tts }
   where
-    subst_ty (AnId id) = AnId $ id `setIdType` substTyUnchecked subst (idType id)
-    subst_ty tt        = tt
+    subst_ty (AnId id)
+      = AnId $ id `setIdType` substTyAddInScope subst (idType id)
+      -- Variables in the interactive context *can* mention free type variables
+      -- because of the runtime debugger. Otherwise you'd expect all
+      -- variables bound in the interactive context to be closed.
+    subst_ty tt
+      = tt
 
 instance Outputable InteractiveImport where
   ppr (IIModule m) = char '*' <> ppr m
@@ -1795,8 +1835,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name
 
         forceUnqualNames :: [Name]
         forceUnqualNames =
-          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon
-                        , starKindTyCon, unicodeStarKindTyCon ]
+          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]
           ++ [ eqTyConName ]
 
         right_name gre = nameModule_maybe (gre_name gre) == Just mod
@@ -2075,7 +2114,7 @@ extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
 extendTypeEnv env thing = extendNameEnv env (getName thing) thing
 
 extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
-extendTypeEnvList env things = foldl extendTypeEnv env things
+extendTypeEnvList env things = foldl' extendTypeEnv env things
 
 extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
 extendTypeEnvWithIds env ids
@@ -2287,7 +2326,6 @@ lookupFixity env n = case lookupNameEnv env n of
 -- * A transformation rule in a module other than the one defining
 --   the function in the head of the rule
 --
--- * A vectorisation pragma
 type WhetherHasOrphans   = Bool
 
 -- | Does this module define family instances?
@@ -2332,6 +2370,9 @@ data Dependencies
                         -- This is used by 'checkFamInstConsistency'.  This
                         -- does NOT include us, unlike 'imp_finsts'. See Note
                         -- [The type family instance consistency story].
+
+         , dep_plgins :: [ModuleName]
+                        -- ^ All the plugins used while compiling this module.
          }
   deriving( Eq )
         -- Equality used only for old/new comparison in MkIface.addFingerprints
@@ -2342,16 +2383,18 @@ instance Binary Dependencies where
                       put_ bh (dep_pkgs deps)
                       put_ bh (dep_orphs deps)
                       put_ bh (dep_finsts deps)
+                      put_ bh (dep_plgins deps)
 
     get bh = do ms <- get bh
                 ps <- get bh
                 os <- get bh
                 fis <- get bh
+                pl <- get bh
                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
-                               dep_finsts = fis })
+                               dep_finsts = fis, dep_plgins = pl })
 
 noDependencies :: Dependencies
-noDependencies = Deps [] [] [] []
+noDependencies = Deps [] [] [] [] []
 
 -- | Records modules for which changes may force recompilation of this module
 -- See wiki: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
@@ -2481,7 +2524,6 @@ type PackageTypeEnv          = TypeEnv
 type PackageRuleBase         = RuleBase
 type PackageInstEnv          = InstEnv
 type PackageFamInstEnv       = FamInstEnv
-type PackageVectInfo         = VectInfo
 type PackageAnnEnv           = AnnEnv
 type PackageCompleteMatchMap = CompleteMatchMap
 
@@ -2543,8 +2585,6 @@ data ExternalPackageState
                                                -- from all the external-package modules
         eps_rule_base    :: !PackageRuleBase,  -- ^ The total 'RuleEnv' accumulated
                                                -- from all the external-package modules
-        eps_vect_info    :: !PackageVectInfo,  -- ^ The total 'VectInfo' accumulated
-                                               -- from all the external-package modules
         eps_ann_env      :: !PackageAnnEnv,    -- ^ The total 'AnnEnv' accumulated
                                                -- from all the external-package modules
         eps_complete_matches :: !PackageCompleteMatchMap,
@@ -2583,11 +2623,11 @@ interface file); so we give it 'noSrcLoc' then.  Later, when we find
 its binding site, we fix it up.
 -}
 
-updNameCacheIO :: HscEnv
-               -> (NameCache -> (NameCache, c))  -- The updating function
-               -> IO c
-updNameCacheIO hsc_env upd_fn
-  = atomicModifyIORef' (hsc_NC hsc_env) upd_fn
+updNameCache :: IORef NameCache
+             -> (NameCache -> (NameCache, c))  -- The updating function
+             -> IO c
+updNameCache ncRef upd_fn
+  = atomicModifyIORef' ncRef upd_fn
 
 mkSOName :: Platform -> FilePath -> FilePath
 mkSOName platform root
@@ -2602,7 +2642,6 @@ soExt :: Platform -> FilePath
 soExt platform
     = case platformOS platform of
       OSDarwin  -> "dylib"
-      OSiOS     -> "dylib"
       OSMinGW32 -> "dll"
       _         -> "so"
 
@@ -2848,119 +2887,6 @@ isHpcUsed (NoHpcInfo { hpcUsed = used }) = used
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Vectorisation Support}
-*                                                                      *
-************************************************************************
-
-The following information is generated and consumed by the vectorisation
-subsystem.  It communicates the vectorisation status of declarations from one
-module to another.
-
-Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo
-below?  We need to know `f' when converting to IfaceVectInfo.  However, during
-vectorisation, we need to know `f_v', whose `Var' we cannot lookup based
-on just the OccName easily in a Core pass.
--}
-
--- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also
--- documentation at 'Vectorise.Env.GlobalEnv'.
---
--- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules,
---     which have been subsequently vectorised in the current module.
---
-data VectInfo
-  = VectInfo
-    { vectInfoVar            :: DVarEnv (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
-    , vectInfoTyCon          :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@
-    , vectInfoDataCon        :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@
-    , vectInfoParallelVars   :: DVarSet                     -- ^ set of parallel variables
-    , vectInfoParallelTyCons :: NameSet                     -- ^ set of parallel type constructors
-    }
-
--- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated
--- across module boundaries.
---
--- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as
---     class selectors — i.e., their mappings are /not/ implicitly generated from the data types.
---     Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines
---     whether that data constructor was vectorised (or is part of an abstractly vectorised type
---     constructor).
---
-data IfaceVectInfo
-  = IfaceVectInfo
-    { ifaceVectInfoVar            :: [Name]  -- ^ All variables in here have a vectorised variant
-    , ifaceVectInfoTyCon          :: [Name]  -- ^ All 'TyCon's in here have a vectorised variant;
-                                             -- the name of the vectorised variant and those of its
-                                             -- data constructors are determined by
-                                             -- 'OccName.mkVectTyConOcc' and
-                                             -- 'OccName.mkVectDataConOcc'; the names of the
-                                             -- isomorphisms are determined by 'OccName.mkVectIsoOcc'
-    , ifaceVectInfoTyConReuse     :: [Name]  -- ^ The vectorised form of all the 'TyCon's in here
-                                             -- coincides with the unconverted form; the name of the
-                                             -- isomorphisms is determined by 'OccName.mkVectIsoOcc'
-    , ifaceVectInfoParallelVars   :: [Name]  -- iface version of 'vectInfoParallelVar'
-    , ifaceVectInfoParallelTyCons :: [Name]  -- iface version of 'vectInfoParallelTyCon'
-    }
-
-noVectInfo :: VectInfo
-noVectInfo
-  = VectInfo emptyDVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet
-
-plusVectInfo :: VectInfo -> VectInfo -> VectInfo
-plusVectInfo vi1 vi2 =
-  VectInfo (vectInfoVar            vi1 `plusDVarEnv`   vectInfoVar            vi2)
-           (vectInfoTyCon          vi1 `plusNameEnv`   vectInfoTyCon          vi2)
-           (vectInfoDataCon        vi1 `plusNameEnv`   vectInfoDataCon        vi2)
-           (vectInfoParallelVars   vi1 `unionDVarSet`  vectInfoParallelVars   vi2)
-           (vectInfoParallelTyCons vi1 `unionNameSet` vectInfoParallelTyCons vi2)
-
-concatVectInfo :: [VectInfo] -> VectInfo
-concatVectInfo = foldr plusVectInfo noVectInfo
-
-noIfaceVectInfo :: IfaceVectInfo
-noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
-
-isNoIfaceVectInfo :: IfaceVectInfo -> Bool
-isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
-  = null l1 && null l2 && null l3 && null l4 && null l5
-
-instance Outputable VectInfo where
-  ppr info = vcat
-             [ text "variables       :" <+> ppr (vectInfoVar            info)
-             , text "tycons          :" <+> ppr (vectInfoTyCon          info)
-             , text "datacons        :" <+> ppr (vectInfoDataCon        info)
-             , text "parallel vars   :" <+> ppr (vectInfoParallelVars   info)
-             , text "parallel tycons :" <+> ppr (vectInfoParallelTyCons info)
-             ]
-
-instance Outputable IfaceVectInfo where
-  ppr info = vcat
-             [ text "variables       :" <+> ppr (ifaceVectInfoVar            info)
-             , text "tycons          :" <+> ppr (ifaceVectInfoTyCon          info)
-             , text "tycons reuse    :" <+> ppr (ifaceVectInfoTyConReuse     info)
-             , text "parallel vars   :" <+> ppr (ifaceVectInfoParallelVars   info)
-             , text "parallel tycons :" <+> ppr (ifaceVectInfoParallelTyCons info)
-             ]
-
-
-instance Binary IfaceVectInfo where
-    put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
-        put_ bh a1
-        put_ bh a2
-        put_ bh a3
-        put_ bh a4
-        put_ bh a5
-    get bh = do
-        a1 <- get bh
-        a2 <- get bh
-        a3 <- get bh
-        a4 <- get bh
-        a5 <- get bh
-        return (IfaceVectInfo a1 a2 a3 a4 a5)
-
-{-
-************************************************************************
-*                                                                      *
 \subsection{Safe Haskell Support}
 *                                                                      *
 ************************************************************************
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 88d5dbe57d..452ccb3e80 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -30,6 +30,8 @@ module InteractiveEval (
         exprType,
         typeKind,
         parseName,
+        getDocs,
+        GetDocsFailure(..),
         showModule,
         moduleIsBootOrNotObjectLinkable,
         parseExpr, compileParsedExpr,
@@ -40,6 +42,8 @@ module InteractiveEval (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import InteractiveEvalTypes
 
 import GHCi
@@ -89,6 +93,8 @@ import Data.Dynamic
 import Data.Either
 import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
 import StringBuffer (stringToStringBuffer)
 import Control.Monad
 import GHC.Exts
@@ -808,7 +814,7 @@ isDecl dflags stmt = do
   case parseThing Parser.parseDeclaration dflags stmt of
     Lexer.POk _ thing ->
       case unLoc thing of
-        SpliceD _ -> False
+        SpliceD _ _ -> False
         _ -> True
     Lexer.PFailed _ _ _ -> False
 
@@ -819,6 +825,70 @@ parseThing parser dflags stmt = do
 
   Lexer.unP parser (Lexer.mkPState dflags buf loc)
 
+getDocs :: GhcMonad m
+        => Name
+        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
+           -- TODO: What about docs for constructors etc.?
+getDocs name =
+  withSession $ \hsc_env -> do
+     case nameModule_maybe name of
+       Nothing -> pure (Left (NameHasNoModule name))
+       Just mod -> do
+         if isInteractiveModule mod
+           then pure (Left InteractiveName)
+           else do
+             ModIface { mi_doc_hdr = mb_doc_hdr
+                      , mi_decl_docs = DeclDocMap dmap
+                      , mi_arg_docs = ArgDocMap amap
+                      } <- liftIO $ hscGetModuleInterface hsc_env mod
+             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
+               then pure (Left (NoDocsInIface mod compiled))
+               else pure (Right ( Map.lookup name dmap
+                                , Map.findWithDefault Map.empty name amap))
+  where
+    compiled =
+      -- TODO: Find a more direct indicator.
+      case nameSrcLoc name of
+        RealSrcLoc {} -> False
+        UnhelpfulLoc {} -> True
+
+-- | Failure modes for 'getDocs'.
+
+-- TODO: Find a way to differentiate between modules loaded without '-haddock'
+-- and modules that contain no docs.
+data GetDocsFailure
+
+    -- | 'nameModule_maybe' returned 'Nothing'.
+  = NameHasNoModule Name
+
+    -- | This is probably because the module was loaded without @-haddock@,
+    -- but it's also possible that the entire module contains no documentation.
+  | NoDocsInIface
+      Module
+      Bool -- ^ 'True': The module was compiled.
+           -- 'False': The module was :loaded.
+
+    -- | The 'Name' was defined interactively.
+  | InteractiveName
+
+instance Outputable GetDocsFailure where
+  ppr (NameHasNoModule name) =
+    quotes (ppr name) <+> text "has no module where we could look for docs."
+  ppr (NoDocsInIface mod compiled) = vcat
+    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
+    , text "This is probably because the module was"
+        <+> text (if compiled then "compiled" else "loaded")
+        <+> text "without '-haddock',"
+    , text "but it's also possible that the module contains no documentation."
+    , text ""
+    , if compiled
+        then text "Try re-compiling with '-haddock'."
+        else text "Try running ':set -haddock' and :load the file again."
+        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
+    ]
+  ppr InteractiveName =
+    text "Docs are unavailable for interactive declarations."
+
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
 
@@ -838,7 +908,7 @@ typeKind normalise str = withSession $ \hsc_env -> do
    liftIO $ hscKcType hsc_env normalise str
 
 -----------------------------------------------------------------------------
--- Compile an expression, run it and deliver the result
+-- Compile an expression, run it, and deliver the result
 
 -- | Parse an expression, the parsed expression can be further processed and
 -- passed to compileParsedExpr.
@@ -846,19 +916,19 @@ parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
 parseExpr expr = withSession $ \hsc_env -> do
   liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
 
--- | Compile an expression, run it and deliver the resulting HValue.
+-- | Compile an expression, run it, and deliver the resulting HValue.
 compileExpr :: GhcMonad m => String -> m HValue
 compileExpr expr = do
   parsed_expr <- parseExpr expr
   compileParsedExpr parsed_expr
 
--- | Compile an expression, run it and deliver the resulting HValue.
+-- | Compile an expression, run it, and deliver the resulting HValue.
 compileExprRemote :: GhcMonad m => String -> m ForeignHValue
 compileExprRemote expr = do
   parsed_expr <- parseExpr expr
   compileParsedExprRemote parsed_expr
 
--- | Compile an parsed expression (before renaming), run it and deliver
+-- | Compile a parsed expression (before renaming), run it, and deliver
 -- the resulting HValue.
 compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
 compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
@@ -868,10 +938,15 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
   -- create a new binding.
   let expr_fs = fsLit "_compileParsedExpr"
       expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
-      let_stmt = L loc . LetStmt . L loc . HsValBinds $
-        ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+      let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $
+        ValBinds noExt
+                     (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+
+  pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
+  let (hvals_io, fix_env) = case pstmt of
+        Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
+        _ -> panic "compileParsedExprRemote"
 
-  Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
   updateFixityEnv fix_env
   status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
   case status of
@@ -892,7 +967,7 @@ dynCompileExpr expr = do
   parsed_expr <- parseExpr expr
   -- > Data.Dynamic.toDyn expr
   let loc = getLoc parsed_expr
-      to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)
+      to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)
                             parsed_expr
   hval <- compileParsedExpr to_dyn_expr
   return (unsafeCoerce# hval :: Dynamic)
@@ -919,20 +994,22 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
 -- RTTI primitives
 
 obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
-obtainTermFromVal hsc_env bound force ty x =
-              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
+obtainTermFromVal hsc_env bound force ty x
+  | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+  | otherwise
+  = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
 
 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 obtainTermFromId hsc_env bound force id =  do
-  let dflags = hsc_dflags hsc_env
-  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+  hv <- Linker.getHValue hsc_env (varName id)
   cvObtainTerm hsc_env bound force (idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 reconstructType hsc_env bound id = do
-  let dflags = hsc_dflags hsc_env
-  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+  hv <- Linker.getHValue hsc_env (varName id)
   cvReconstructType hsc_env bound (idType id) hv
 
 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index cb0121950f..3bc043f88b 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -- -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow, 2005-2007
@@ -14,6 +12,8 @@ module InteractiveEvalTypes (
         BreakInfo(..)
         ) where
 
+import GhcPrelude
+
 import GHCi.RemoteTypes
 import GHCi.Message (EvalExpr, ResumeContext)
 import Id
@@ -25,11 +25,7 @@ import SrcLoc
 import Exception
 
 import Data.Word
-#if MIN_VERSION_base(4,9,0)
 import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
 
 data ExecOptions
  = ExecOptions
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 23f37da64d..b003f5fa5a 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -30,6 +30,8 @@ module PackageConfig (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import GHC.PackageDb
 import Data.Version
 
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 2c5833fae4..04efa1fe51 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -7,7 +7,7 @@ module Packages (
         module PackageConfig,
 
         -- * Reading the package config, and processing cmdline args
-        PackageState(preloadPackages, explicitPackages, requirementContext),
+        PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext),
         PackageConfigMap,
         emptyPackageState,
         initPackages,
@@ -35,6 +35,8 @@ module Packages (
         LookupResult(..),
         ModuleSuggestion(..),
         ModuleOrigin(..),
+        UnusablePackageReason(..),
+        pprReason,
 
         -- * Inspecting the set of packages in scope
         getPackageIncludePath,
@@ -46,8 +48,9 @@ module Packages (
         getPackageConfigMap,
         getPreloadPackagesAnd,
 
+        collectArchives,
         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
-        packageHsLibs,
+        packageHsLibs, getLibs,
 
         -- * Utils
         unwireUnitId,
@@ -61,6 +64,8 @@ where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import GHC.PackageDb
 import PackageConfig
 import DynFlags
@@ -71,6 +76,7 @@ import UniqSet
 import Module
 import Util
 import Panic
+import Platform
 import Outputable
 import Maybes
 
@@ -88,12 +94,9 @@ import Data.Char ( toUpper )
 import Data.List as List
 import Data.Map (Map)
 import Data.Set (Set)
-import Data.Maybe (mapMaybe)
 import Data.Monoid (First(..))
-#if __GLASGOW_HASKELL__ > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
-#endif
 import qualified Data.Map as Map
 import qualified Data.Map.Strict as MapStrict
 import qualified Data.Set as Set
@@ -123,7 +126,7 @@ import Data.Version
 --     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
 --     their dependencies.
 --
---   * When searching for a module from an preload import declaration,
+--   * When searching for a module from a preload import declaration,
 --     only the exposed modules in @exposedPackages@ are valid.
 --
 --   * When searching for a module from an implicit import, all modules
@@ -156,6 +159,8 @@ data ModuleOrigin =
     -- (But maybe the user didn't realize), so we'll still keep track
     -- of these modules.)
     ModHidden
+    -- | Module is unavailable because the package is unusable.
+  | ModUnusable UnusablePackageReason
     -- | Module is public, and could have come from some places.
   | ModOrigin {
         -- | @Just False@ means that this module is in
@@ -175,6 +180,7 @@ data ModuleOrigin =
 
 instance Outputable ModuleOrigin where
     ppr ModHidden = text "hidden module"
+    ppr (ModUnusable _) = text "unusable module"
     ppr (ModOrigin e res rhs f) = sep (punctuate comma (
         (case e of
             Nothing -> []
@@ -207,7 +213,6 @@ fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
 fromFlag :: ModuleOrigin
 fromFlag = ModOrigin Nothing [] [] True
 
-#if __GLASGOW_HASKELL__ > 710
 instance Semigroup ModuleOrigin where
     ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
         ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
@@ -217,23 +222,16 @@ instance Semigroup ModuleOrigin where
             g Nothing x = x
             g x Nothing = x
     _x <> _y = panic "ModOrigin: hidden module redefined"
-#endif
 
 instance Monoid ModuleOrigin where
     mempty = ModOrigin Nothing [] [] False
-    mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
-        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
-      where g (Just b) (Just b')
-                | b == b'   = Just b
-                | otherwise = panic "ModOrigin: package both exposed/hidden"
-            g Nothing x = x
-            g x Nothing = x
-    mappend _ _ = panic "ModOrigin: hidden module redefined"
+    mappend = (Semigroup.<>)
 
 -- | Is the name from the import actually visible? (i.e. does it cause
 -- ambiguity, or is it only relevant when we're making suggestions?)
 originVisible :: ModuleOrigin -> Bool
 originVisible ModHidden = False
+originVisible (ModUnusable _) = False
 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
 
 -- | Are there actually no providers for this module?  This will never occur
@@ -287,6 +285,17 @@ instance Outputable UnitVisibility where
         uv_requirements = reqs,
         uv_explicit = explicit
     }) = ppr (b, rns, mb_pn, reqs, explicit)
+
+instance Semigroup UnitVisibility where
+    uv1 <> uv2
+        = UnitVisibility
+          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
+          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
+          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
+          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
+          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
+          }
+
 instance Monoid UnitVisibility where
     mempty = UnitVisibility
              { uv_expose_all = False
@@ -295,14 +304,7 @@ instance Monoid UnitVisibility where
              , uv_requirements = Map.empty
              , uv_explicit = False
              }
-    mappend uv1 uv2
-        = UnitVisibility
-          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
-          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
-          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
-          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
-          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
-          }
+    mappend = (Semigroup.<>)
 
 type WiredUnitId = DefUnitId
 type PreloadUnitId = InstalledUnitId
@@ -415,7 +417,7 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
 extendPackageConfigMap
    :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
 extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
-  = PackageConfigMap (foldl add pkg_map new_pkgs) closure
+  = PackageConfigMap (foldl' add pkg_map new_pkgs) closure
     -- We also add the expanded version of the packageConfigId, so that
     -- 'improveUnitId' can find it.
   where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
@@ -915,15 +917,6 @@ packageFlagErr :: DynFlags
                -> PackageFlag
                -> [(PackageConfig, UnusablePackageReason)]
                -> IO a
-
--- for missing DPH package we emit a more helpful error message, because
--- this may be the result of using -fdph-par or -fdph-seq.
-packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
-  | is_dph_package pkg
-  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
-  where dph_err = text "the " <> text pkg <> text " package is not installed."
-                  $$ text "To install it: \"cabal install dph\"."
-        is_dph_package pkg = "dph" `isPrefixOf` pkg
 packageFlagErr dflags flag reasons
   = packageFlagErr' dflags (pprFlag flag) reasons
 
@@ -1149,7 +1142,8 @@ pprReason pref reason = case reason of
       pref <+> text "unusable due to cyclic dependencies:" $$
         nest 2 (hsep (map ppr deps))
   IgnoredDependencies deps ->
-      pref <+> text "unusable due to ignored dependencies:" $$
+      pref <+> text ("unusable because the -ignore-package flag was used to " ++
+                     "ignore at least one of its dependencies:") $$
         nest 2 (hsep (map ppr deps))
   ShadowedDependencies deps ->
       pref <+> text "unusable due to shadowed dependencies:" $$
@@ -1525,7 +1519,7 @@ mkPackageState dflags dbs preload0 = do
   --
   let preload1 = Map.keys (Map.filter uv_explicit vis_map)
 
-  let pkgname_map = foldl add Map.empty pkgs2
+  let pkgname_map = foldl' add Map.empty pkgs2
         where add pn_map p
                 = Map.insert (packageName p) (componentId p) pn_map
 
@@ -1561,7 +1555,10 @@ mkPackageState dflags dbs preload0 = do
   dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
-  let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map
+  let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map
+      mod_map2 = mkUnusableModuleToPkgConfAll unusable
+      mod_map = Map.union mod_map1 mod_map2
+
   when (dopt Opt_D_dump_mod_map dflags) $
       printInfoForUser (dflags { pprCols = 200 })
                        alwaysQualify (pprModuleMap mod_map)
@@ -1600,12 +1597,36 @@ mkModuleToPkgConfAll
   -> VisibilityMap
   -> ModuleToPkgConfAll
 mkModuleToPkgConfAll dflags pkg_db vis_map =
-    Map.foldlWithKey extend_modmap emptyMap vis_map
+    -- What should we fold on?  Both situations are awkward:
+    --
+    --    * Folding on the visibility map means that we won't create
+    --      entries for packages that aren't mentioned in vis_map
+    --      (e.g., hidden packages, causing #14717)
+    --
+    --    * Folding on pkg_db is awkward because if we have an
+    --      Backpack instantiation, we need to possibly add a
+    --      package from pkg_db multiple times to the actual
+    --      ModuleToPkgConfAll.  Also, we don't really want
+    --      definite package instantiations to show up in the
+    --      list of possibilities.
+    --
+    -- So what will we do instead?  We'll extend vis_map with
+    -- entries for every definite (for non-Backpack) and
+    -- indefinite (for Backpack) package, so that we get the
+    -- hidden entries we need.
+    Map.foldlWithKey extend_modmap emptyMap vis_map_extended
  where
+  vis_map_extended = Map.union vis_map {- preferred -} default_vis
+
+  default_vis = Map.fromList
+                  [ (packageConfigId pkg, mempty)
+                  | pkg <- eltsUDFM (unPackageConfigMap pkg_db)
+                  -- Exclude specific instantiations of an indefinite
+                  -- package
+                  , indefinite pkg || null (instantiatedWith pkg)
+                  ]
+
   emptyMap = Map.empty
-  sing pk m _ = Map.singleton (mkModule pk m)
-  addListTo = foldl' merge
-  merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
   setOrigins m os = fmap (const os) m
   extend_modmap modmap uid
     UnitVisibility { uv_expose_all = b, uv_renamings = rns }
@@ -1633,19 +1654,19 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
     es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
     es e = do
      (m, exposedReexport) <- exposed_mods
-     let (pk', m', pkg', origin') =
+     let (pk', m', origin') =
           case exposedReexport of
-           Nothing -> (pk, m, pkg, fromExposedModules e)
+           Nothing -> (pk, m, fromExposedModules e)
            Just (Module pk' m') ->
             let pkg' = pkg_lookup pk'
-            in (pk', m', pkg', fromReexportedModules e pkg')
-     return (m, sing pk' m' pkg' origin')
+            in (pk', m', fromReexportedModules e pkg')
+     return (m, mkModMap pk' m' origin')
 
     esmap :: UniqFM (Map Module ModuleOrigin)
     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
                                  -- be overwritten
 
-    hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
+    hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]
 
     pk = packageConfigId pkg
     pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid
@@ -1654,6 +1675,43 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
     exposed_mods = exposedModules pkg
     hidden_mods = hiddenModules pkg
 
+-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages.
+mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll
+mkUnusableModuleToPkgConfAll unusables =
+    Map.foldl' extend_modmap Map.empty unusables
+ where
+    extend_modmap modmap (pkg, reason) = addListTo modmap bindings
+      where bindings :: [(ModuleName, Map Module ModuleOrigin)]
+            bindings = exposed ++ hidden
+
+            origin = ModUnusable reason
+            pkg_id = packageConfigId pkg
+
+            exposed = map get_exposed exposed_mods
+            hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods]
+
+            get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin)
+            get_exposed (mod, _)         = (mod, mkModMap pkg_id mod origin)
+
+            exposed_mods = exposedModules pkg
+            hidden_mods = hiddenModules pkg
+
+-- | Add a list of key/value pairs to a nested map.
+--
+-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks
+-- when reloading modules in GHCi (see Trac #4029). This ensures that each
+-- value is forced before installing into the map.
+addListTo :: (Monoid a, Ord k1, Ord k2)
+          => Map k1 (Map k2 a)
+          -> [(k1, Map k2 a)]
+          -> Map k1 (Map k2 a)
+addListTo = foldl' merge
+  where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m
+
+-- | Create a singleton module mapping
+mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
+mkModMap pkg mod = Map.singleton (mkModule pkg mod)
+
 -- -----------------------------------------------------------------------------
 -- Extracting information from the packages in scope
 
@@ -1695,6 +1753,21 @@ collectLinkOpts dflags ps =
         concatMap (map ("-l" ++) . extraLibraries) ps,
         concatMap ldOptions ps
     )
+collectArchives :: DynFlags -> PackageConfig -> IO [FilePath]
+collectArchives dflags pc =
+  filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
+                        | searchPath <- searchPaths
+                        , lib <- libs ]
+  where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc
+        libs        = packageHsLibs dflags pc ++ extraLibraries pc
+
+getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)]
+getLibs dflags pkgs = do
+  ps <- getPreloadPackagesAnd dflags pkgs
+  fmap concat . forM ps $ \p -> do
+    let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p]
+                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]
+    filterM (doesFileExist . fst) candidates
 
 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
@@ -1726,7 +1799,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
          | otherwise
             = panic ("Don't understand library name " ++ x)
 
+        -- Add _thr and other rts suffixes to packages named
+        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts
+        -- package is called `rts` only.  However the tooling
+        -- usually expects a package name to have a version.
+        -- As such we will gradually move towards the `rts-1.0`
+        -- package name, at which point the `rts` package name
+        -- will eventually be unused.
+        --
+        -- This change elevates the need to add custom hooks
+        -- and handling specifically for the `rts` package for
+        -- example in ghc-cabal.
         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
+        addSuffix rts@"HSrts-1.0"= rts       ++ (expandTag rts_tag)
         addSuffix other_lib      = other_lib ++ (expandTag tag)
 
         expandTag t | null t = ""
@@ -1782,6 +1867,9 @@ data LookupResult =
     -- an exact name match.  First is due to package hidden, second
     -- is due to module being hidden
   | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
+    -- | No modules found, but there were some unusable ones with
+    -- an exact name match
+  | LookupUnusable [(Module, ModuleOrigin)]
     -- | Nothing found, here are some suggested different names
   | LookupNotFound [ModuleSuggestion] -- suggestions
 
@@ -1813,20 +1901,28 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
   = case Map.lookup m mod_map of
         Nothing -> LookupNotFound suggestions
         Just xs ->
-          case foldl' classify ([],[],[]) (Map.toList xs) of
-            ([], [], []) -> LookupNotFound suggestions
-            (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
-            (_, _, exposed@(_:_))        -> LookupMultiple exposed
-            (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
+          case foldl' classify ([],[],[], []) (Map.toList xs) of
+            ([], [], [], []) -> LookupNotFound suggestions
+            (_, _, _, [(m, _)])             -> LookupFound m (mod_pkg m)
+            (_, _, _, exposed@(_:_))        -> LookupMultiple exposed
+            ([], [], unusable@(_:_), [])    -> LookupUnusable unusable
+            (hidden_pkg, hidden_mod, _, []) ->
+              LookupHidden hidden_pkg hidden_mod
   where
-    classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
+    classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) =
       let origin = filterOrigin mb_pn (mod_pkg m) origin0
           x = (m, origin)
       in case origin of
-          ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)
-          _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)
-            | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
-            | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)
+          ModHidden
+            -> (hidden_pkg, x:hidden_mod, unusable, exposed)
+          ModUnusable _
+            -> (hidden_pkg, hidden_mod, x:unusable, exposed)
+          _ | originEmpty origin
+            -> (hidden_pkg,   hidden_mod, unusable, exposed)
+            | originVisible origin
+            -> (hidden_pkg, hidden_mod, unusable, x:exposed)
+            | otherwise
+            -> (x:hidden_pkg, hidden_mod, unusable, exposed)
 
     pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m)
     mod_pkg = pkg_lookup . moduleUnitId
@@ -1842,6 +1938,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn
     filterOrigin (Just pn) pkg o =
       case o of
           ModHidden -> if go pkg then ModHidden else mempty
+          (ModUnusable _) -> if go pkg then o else mempty
           ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
                       fromHiddenReexport = rhs }
             -> ModOrigin {
@@ -1875,8 +1972,16 @@ listVisibleModuleNames dflags =
 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
 -- 'PackageConfig's
 getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig]
-getPreloadPackagesAnd dflags pkgids =
+getPreloadPackagesAnd dflags pkgids0 =
   let
+      pkgids  = pkgids0 ++
+                  -- An indefinite package will have insts to HOLE,
+                  -- which is not a real package. Don't look it up.
+                  -- Fixes #14525
+                  if isIndefinite dflags
+                    then []
+                    else map (toInstalledUnitId . moduleUnitId . snd)
+                             (thisUnitIdInsts dflags)
       state   = pkgState dflags
       pkg_map = pkgIdMap state
       preload = preloadPackages state
@@ -1957,7 +2062,7 @@ isDllName :: DynFlags -> Module -> Name -> Bool
 -- the symbol comes from another dynamically-linked package,
 -- and applies on all platforms, not just Windows
 isDllName dflags this_mod name
-  | WayDyn `notElem` ways dflags = False
+  | not (gopt Opt_ExternalDynamicRefs dflags) = False
   | Just mod <- nameModule_maybe name
     -- Issue #8696 - when GHC is dynamically linked, it will attempt
     -- to load the dynamic dependencies of object files at compile
@@ -1971,16 +2076,19 @@ isDllName dflags this_mod name
     -- In the mean time, always force dynamic indirections to be
     -- generated: when the module name isn't the module being
     -- compiled, references are dynamic.
-    = if mod /= this_mod
-      then True
-      else case dllSplit dflags of
-           Nothing -> False
-           Just ss ->
-               let findMod m = let modStr = moduleNameString (moduleName m)
-                               in case find (modStr `Set.member`) ss of
-                                  Just i -> i
-                                  Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
-               in findMod mod /= findMod this_mod
+    = case platformOS $ targetPlatform dflags of
+        -- On Windows the hack for #8696 makes it unlinkable.
+        -- As the entire setup of the code from Cmm down to the RTS expects
+        -- the use of trampolines for the imported functions only when
+        -- doing intra-package linking, e.g. refering to a symbol defined in the same
+        -- package should not use a trampoline.
+        -- I much rather have dynamic TH not supported than the entire Dynamic linking
+        -- not due to a hack.
+        -- Also not sure this would break on Windows anyway.
+        OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod
+
+        -- For the other platforms, still perform the hack
+        _         -> mod /= this_mod
 
   | otherwise = False  -- no, it is not even an external name
 
diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot
index 0ed59db92b..80b9ebf8ae 100644
--- a/compiler/main/Packages.hs-boot
+++ b/compiler/main/Packages.hs-boot
@@ -1,4 +1,5 @@
 module Packages where
+import GhcPrelude
 import {-# SOURCE #-} DynFlags(DynFlags)
 import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId)
 data PackageState
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index c8345276fa..bbb1a17b65 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -9,6 +9,8 @@ module PipelineMonad (
   , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs
   ) where
 
+import GhcPrelude
+
 import MonadUtils
 import Outputable
 import DynFlags
diff --git a/compiler/main/PlatformConstants.hs b/compiler/main/PlatformConstants.hs
index c9a4072206..96b0f70e6d 100644
--- a/compiler/main/PlatformConstants.hs
+++ b/compiler/main/PlatformConstants.hs
@@ -10,6 +10,8 @@
 
 module PlatformConstants (PlatformConstants(..)) where
 
+import GhcPrelude
+
 -- Produced by deriveConstants
 #include "GHCConstantsHaskellType.hs"
 
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index 273bf7abd9..e83ec08805 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -1,20 +1,39 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
 module Plugins (
-    FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction,
-    Plugin(..), CommandLineOption,
-    defaultPlugin
+      FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
+    , Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName
+    , defaultPlugin, keepRenamedSource, withPlugins, withPlugins_
+    , PluginRecompile(..)
+    , purePlugin, impurePlugin, flagRecompile
     ) where
 
-import CoreMonad ( CoreToDo, CoreM )
-import TcRnTypes ( TcPlugin )
+import GhcPrelude
+
+import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
+import qualified TcRnTypes
+import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
+import HsSyn
+import DynFlags
+import HscTypes
 import GhcMonad
 import DriverPhases
+import Module ( ModuleName, Module(moduleName))
+import Fingerprint
+import Data.List
+import Outputable (Outputable(..), text, (<+>))
+
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
 
+import Control.Monad
 
 -- | Command line options gathered from the -PModule.Name:stuff syntax
 -- are given to you as this type
 type CommandLineOption = String
 
--- | 'Plugin' is the core compiler plugin data type. Try to avoid
+-- | 'Plugin' is the compiler plugin data type. Try to avoid
 -- constructing one of these directly, and just modify some fields of
 -- 'defaultPlugin' instead: this is to try and preserve source-code
 -- compatibility when we add fields to this.
@@ -22,24 +41,148 @@ type CommandLineOption = String
 -- Nonetheless, this API is preliminary and highly likely to change in
 -- the future.
 data Plugin = Plugin {
-    installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+    installCoreToDos :: CorePlugin
     -- ^ Modify the Core pipeline that will be used for compilation.
     -- This is called as the Core pipeline is built for every module
     -- being compiled, and plugins get the opportunity to modify the
     -- pipeline in a nondeterministic order.
-  , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin
+  , tcPlugin :: TcPlugin
     -- ^ An optional typechecker plugin, which may modify the
     -- behaviour of the constraint solver.
+  , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
+    -- ^ Specify how the plugin should affect recompilation.
+  , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                            -> Hsc HsParsedModule
+    -- ^ Modify the module when it is parsed. This is called by
+    -- HscMain when the parsing is successful.
+  , renamedResultAction :: [CommandLineOption] -> TcGblEnv
+                                -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
+    -- ^ Modify each group after it is renamed. This is called after each
+    -- `HsGroup` has been renamed.
+  , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv
+                               -> TcM TcGblEnv
+    -- ^ Modify the module when it is type checked. This is called add the
+    -- very end of typechecking.
+  , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc
+                         -> TcM (LHsExpr GhcTc)
+    -- ^ Modify the TH splice or quasiqoute before it is run.
+  , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface
+                                          -> IfM lcl ModIface
+    -- ^ Modify an interface that have been loaded. This is called by
+    -- LoadIface when an interface is successfully loaded. Not applied to
+    -- the loading of the plugin interface. Tools that rely on information from
+    -- modules other than the currently compiled one should implement this
+    -- function.
   }
 
+-- Note [Source plugins]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The `Plugin` datatype have been extended by fields that allow access to the
+-- different inner representations that are generated during the compilation
+-- process. These fields are `parsedResultAction`, `renamedResultAction`,
+-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`.
+--
+-- The main purpose of these plugins is to help tool developers. They allow
+-- development tools to extract the information about the source code of a big
+-- Haskell project during the normal build procedure. In this case the plugin
+-- acts as the tools access point to the compiler that can be controlled by
+-- compiler flags. This is important because the manipulation of compiler flags
+-- is supported by most build environment.
+--
+-- For the full discussion, check the full proposal at:
+-- https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal
+
+
+-- | A plugin with its arguments. The result of loading the plugin.
+data LoadedPlugin = LoadedPlugin {
+    lpPlugin :: Plugin
+    -- ^ the actual callable plugin
+  , lpModule :: ModIface
+    -- ^ the module containing the plugin
+  , lpArguments :: [CommandLineOption]
+    -- ^ command line arguments for the plugin
+  }
+
+lpModuleName :: LoadedPlugin -> ModuleName
+lpModuleName = moduleName . mi_module . lpModule
+
+
+data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
+
+instance Outputable PluginRecompile where
+  ppr ForceRecompile = text "ForceRecompile"
+  ppr NoForceRecompile = text "NoForceRecompile"
+  ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp
+
+instance Semigroup PluginRecompile where
+  ForceRecompile <> _ = ForceRecompile
+  NoForceRecompile <> r = r
+  MaybeRecompile fp <> NoForceRecompile   = MaybeRecompile fp
+  MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp'])
+  MaybeRecompile _fp <> ForceRecompile     = ForceRecompile
+
+instance Monoid PluginRecompile where
+  mempty = NoForceRecompile
+#if __GLASGOW_HASKELL__ < 804
+  mappend = (Data.Semigroup.<>)
+#endif
+
+type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin
+
+purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
+purePlugin _args = return NoForceRecompile
+
+impurePlugin _args = return ForceRecompile
+
+flagRecompile =
+  return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort
+
 -- | Default plugin: does nothing at all! For compatibility reasons
 -- you should base all your plugin definitions on this default value.
 defaultPlugin :: Plugin
 defaultPlugin = Plugin {
-        installCoreToDos = const return
-      , tcPlugin         = const Nothing
+        installCoreToDos      = const return
+      , tcPlugin              = const Nothing
+      , pluginRecompile  = impurePlugin
+      , renamedResultAction   = \_ env grp -> return (env, grp)
+      , parsedResultAction    = \_ _ -> return
+      , typeCheckResultAction = \_ _ -> return
+      , spliceRunAction       = \_ -> return
+      , interfaceLoadAction   = \_ -> return
     }
 
+
+-- | A renamer plugin which mades the renamed source available in
+-- a typechecker plugin.
+keepRenamedSource :: [CommandLineOption] -> TcGblEnv
+                  -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
+keepRenamedSource _ gbl_env group =
+  return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env)
+                  , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group)
+  where
+    update_exports Nothing = Just []
+    update_exports m = m
+
+    update Nothing = Just emptyRnGroup
+    update m       = m
+
+
+type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
+type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
+
+-- | Perform an operation by using all of the plugins in turn.
+withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
+withPlugins df transformation input
+  = foldM (\arg (LoadedPlugin p _ opts) -> transformation p opts arg)
+          input (plugins df)
+
+-- | Perform a constant operation by using all of the plugins in turn.
+withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
+withPlugins_ df transformation input
+  = mapM_ (\(LoadedPlugin p _ opts) -> transformation p opts input)
+          (plugins df)
+
 type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
 data FrontendPlugin = FrontendPlugin {
       frontend :: FrontendPluginAction
diff --git a/compiler/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot
new file mode 100644
index 0000000000..4ccd3d8402
--- /dev/null
+++ b/compiler/main/Plugins.hs-boot
@@ -0,0 +1,9 @@
+-- The plugins datatype is stored in DynFlags, so it needs to be
+-- exposed without importing all of its implementation.
+module Plugins where
+
+import GhcPrelude ()
+
+data Plugin
+
+data LoadedPlugin
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 86098a5e7f..b0a72cf499 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -19,6 +19,8 @@ module PprTyThing (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Type    ( TyThing(..) )
 import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
   , showToHeader, pprIfaceDecl )
@@ -35,39 +37,68 @@ import Outputable
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
 
-{-  Note [Pretty-printing TyThings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We pretty-print a TyThing by converting it to an IfaceDecl,
-and pretty-printing that (see ppr_ty_thing below).
-Here is why:
+{- Note [Pretty printing via IfaceSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Our general plan for prett-printing
+  - Types
+  - TyCons
+  - Classes
+  - Pattern synonyms
+  ...etc...
+
+is to convert them to IfaceSyn, and pretty-print that. For example
+  - pprType converts a Type to an IfaceType, and pretty prints that.
+  - pprTyThing converts the TyThing to an IfaceDecl,
+    and pretty prints that.
+
+So IfaceSyn play a dual role:
+  - it's the internal version of an interface files
+  - it's used for pretty-printing
 
-* When pretty-printing (a type, say), the idiomatic solution is not to
-  "rename type variables on the fly", but rather to "tidy" the type
-  (which gives each variable a distinct print-name), and then
-  pretty-print it (without renaming). Separate the two
-  concerns. Functions like tidyType do this.
+Why do this?
 
-* Alas, for type constructors, TyCon, tidying does not work well,
+* A significant reason is that we need to be able
+  to pretty-print IfaceSyn (to display Foo.hi), and it was a
+  pain to duplicate masses of pretty-printing goop, esp for
+  Type and IfaceType.
+
+* When pretty-printing (a type, say), we want to tidy (with
+  tidyType) to avoids having (forall a a. blah) where the two
+  a's have different uniques.
+
+  Alas, for type constructors, TyCon, tidying does not work well,
   because a TyCon includes DataCons which include Types, which mention
   TyCons. And tidying can't tidy a mutually recursive data structure
   graph, only trees.
 
-* One alternative would be to ensure that TyCons get type variables
-  with distinct print-names. That's ok for type variables but less
-  easy for kind variables. Processing data type declarations is
-  already so complicated that I don't think it's sensible to add the
-  extra requirement that it generates only "pretty" types and kinds.
-
-*  One place the non-pretty names can show up is in GHCi. But another
-   is in interface files. Look at MkIface.tyThingToIfaceDecl which
-   converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it
-   already does tidying as part of that conversion!  Why? Because
-   interface files contains fast-strings, not uniques, so the names
-   must at least be distinct.
-
-So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can
-print that.  Of course, that means that pretty-printing IfaceDecls
-must be careful to display nice user-friendly results, but that's ok.
+* Interface files contains fast-strings, not uniques, so the very same
+  tidying must take place when we convert to IfaceDecl. E.g.
+  MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
+  Class etc) to an IfaceDecl.
+
+  Bottom line: IfaceDecls are already 'tidy', so it's straightforward
+  to print them.
+
+* An alternative I once explored was to ensure that TyCons get type
+  variables with distinct print-names. That's ok for type variables
+  but less easy for kind variables. Processing data type declarations
+  is already so complicated that I don't think it's sensible to add
+  the extra requirement that it generates only "pretty" types and
+  kinds.
+
+Consequences:
+
+- IfaceSyn (and IfaceType) must contain enough information to
+  print nicely.  Hence, for example, the IfaceAppArgs type, which
+  allows us to suppress invisible kind arguments in types
+  (see Note [Suppressing invisible arguments] in IfaceType)
+
+- In a few places we have info that is used only for pretty-printing,
+  and is totally ignored when turning IfaceSyn back into TyCons
+  etc (in TcIface). For example, IfaceClosedSynFamilyTyCon
+  stores a [IfaceAxBranch] that is used only for pretty-printing.
+
+- See Note [Free tyvars in IfaceType] in IfaceType
 
 See #7730, #8776 for details   -}
 
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
index ff0d47e4b1..47547fca5b 100644
--- a/compiler/main/StaticPtrTable.hs
+++ b/compiler/main/StaticPtrTable.hs
@@ -60,13 +60,13 @@ Here is a running example:
          in ...(static k)...
 
 * The renamer looks for out-of-scope names in the body of the static
-  form, as always If all names are in scope, the free variables of the
+  form, as always. If all names are in scope, the free variables of the
   body are stored in AST at the location of the static form.
 
 * The typechecker verifies that all free variables occurring in the
   static form are floatable to top level (see Note [Meaning of
-  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable, even
-  though it is bound in a nested let, we are fine.
+  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable.
+  Even though it is bound in a nested let, we are fine.
 
 * The desugarer replaces the static form with an application of the
   function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
@@ -122,6 +122,8 @@ Here is a running example:
   in upsweep after we have compiled the module (see GhcMake.upsweep').
 -}
 
+import GhcPrelude
+
 import CLabel
 import CoreSyn
 import CoreUtils (collectMakeStaticArgs)
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 3d16124d72..9bbce19602 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -8,123 +8,63 @@
 -----------------------------------------------------------------------------
 -}
 
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}
 
 module SysTools (
-        -- Initialisation
+        -- * Initialisation
         initSysTools,
+        initLlvmConfig,
 
-        -- Interface to system tools
-        runUnlit, runCpp, runCc, -- [Option] -> IO ()
-        runPp,                   -- [Option] -> IO ()
-        runSplit,                -- [Option] -> IO ()
-        runAs, runLink, runLibtool, -- [Option] -> IO ()
-        runMkDLL,
-        runWindres,
-        runLlvmOpt,
-        runLlvmLlc,
-        runClang,
-        figureLlvmVersion,
-
-        getLinkerInfo,
-        getCompilerInfo,
+        -- * Interface to system tools
+        module SysTools.Tasks,
+        module SysTools.Info,
 
         linkDynLib,
 
-        askLd,
-
-        touch,                  -- String -> String -> IO ()
         copy,
         copyWithHeader,
 
+        -- * General utilities
         Option(..),
+        expandTopDir,
+
+        -- * Platform-specifics
+        libmLinkOpts,
 
-        -- frameworks
+        -- * Mac OS X frameworks
         getPkgFrameworkOpts,
         getFrameworkOpts
  ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Module
 import Packages
 import Config
 import Outputable
 import ErrUtils
-import Panic
 import Platform
 import Util
 import DynFlags
-import Exception
-import FileCleanup
+import Fingerprint
 
-import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
-
-import Data.IORef
-import System.Exit
-import System.Environment
 import System.FilePath
 import System.IO
-import System.IO.Error as IO
 import System.Directory
-import Data.Char
-import Data.List
-
-#if defined(mingw32_HOST_OS)
-#if MIN_VERSION_Win32(2,5,0)
-import qualified System.Win32.Types as Win32
-#else
-import qualified System.Win32.Info as Win32
-#endif
-import Foreign
-import Foreign.C.String
-import System.Win32.Types (DWORD, LPTSTR, HANDLE)
-import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
-import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
-import System.Win32.DLL (loadLibrary, getProcAddress)
-#endif
-
-import System.Process
-import Control.Concurrent
-import FastString
-import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
-
-#if defined(mingw32_HOST_OS)
-# if defined(i386_HOST_ARCH)
-#  define WINDOWS_CCONV stdcall
-# elif defined(x86_64_HOST_ARCH)
-#  define WINDOWS_CCONV ccall
-# else
-#  error Unknown mingw32 arch
-# endif
-#endif
+import SysTools.ExtraObj
+import SysTools.Info
+import SysTools.Tasks
+import SysTools.BaseDir
 
 {-
-How GHC finds its files
-~~~~~~~~~~~~~~~~~~~~~~~
-
-[Note topdir]
-
-GHC needs various support files (library packages, RTS etc), plus
-various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
-the root of GHC's support files
-
-On Unix:
-  - ghc always has a shell wrapper that passes a -B<dir> option
-
-On Windows:
-  - ghc never has a shell wrapper.
-  - we can find the location of the ghc binary, which is
-        $topdir/<foo>/<something>.exe
-    where <something> may be "ghc", "ghc-stage2", or similar
-  - we strip off the "<foo>/<something>.exe" to leave $topdir.
-
-from topdir we can find package.conf, ghc-asm, etc.
-
+Note [How GHC finds toolchain utilities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 are, and initialises mutable variables to make it easy to call them.
-To to this, it makes use of definitions in Config.hs, which is a Haskell
+To do this, it makes use of definitions in Config.hs, which is a Haskell
 file containing variables whose value is figured out by the build system.
 
 Config.hs contains two sorts of things
@@ -140,7 +80,6 @@ Config.hs contains two sorts of things
                    for use when running *in-place* in a build tree (only)
 
 
-
 ---------------------------------------------
 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 
@@ -171,23 +110,43 @@ stuff.
 ************************************************************************
 -}
 
-initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
+initLlvmConfig :: String
+               -> IO LlvmConfig
+initLlvmConfig top_dir
+  = do
+      targets <- readAndParse "llvm-targets" mkLlvmTarget
+      passes <- readAndParse "llvm-passes" id
+      return (targets, passes)
+  where
+    readAndParse name builder =
+      do let llvmConfigFile = top_dir </> name
+         llvmConfigStr <- readFile llvmConfigFile
+         case maybeReadFuzzy llvmConfigStr of
+           Just s -> return (fmap builder <$> s)
+           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)
+
+    mkLlvmTarget :: (String, String, String) -> LlvmTarget
+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)
+
+
+initSysTools :: String          -- TopDir path
              -> IO Settings     -- Set all the mutable variables above, holding
                                 --      (a) the system programs
                                 --      (b) the package-config file
                                 --      (c) the GHC usage message
-initSysTools mbMinusB
-  = do top_dir <- findTopDir mbMinusB
-             -- see [Note topdir]
+initSysTools top_dir
+  = do       -- see Note [topdir: How GHC finds its files]
              -- NB: top_dir is assumed to be in standard Unix
              -- format, '/' separated
+       mtool_dir <- findToolDir top_dir
+             -- see Note [tooldir: How GHC finds mingw and perl on Windows]
 
-       let settingsFile = top_dir </> "settings"
-           platformConstantsFile = top_dir </> "platformConstants"
-           installed :: FilePath -> FilePath
+       let installed :: FilePath -> FilePath
            installed file = top_dir </> file
            libexec :: FilePath -> FilePath
            libexec file = top_dir </> "bin" </> file
+           settingsFile = installed "settings"
+           platformConstantsFile = installed "platformConstants"
 
        settingsStr <- readFile settingsFile
        platformConstantsStr <- readFile platformConstantsFile
@@ -203,16 +162,9 @@ initSysTools mbMinusB
                                 pgmError ("Can't parse " ++
                                           show platformConstantsFile)
        let getSetting key = case lookup key mySettings of
-                            Just xs ->
-                                return $ case stripPrefix "$topdir" xs of
-                                         Just [] ->
-                                             top_dir
-                                         Just xs'@(c:_)
-                                          | isPathSeparator c ->
-                                             top_dir ++ xs'
-                                         _ ->
-                                             xs
+                            Just xs -> return $ expandTopDir top_dir xs
                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           getToolSetting key = expandToolDir mtool_dir <$> getSetting key
            getBooleanSetting key = case lookup key mySettings of
                                    Just "YES" -> return True
                                    Just "NO" -> return False
@@ -234,14 +186,15 @@ initSysTools mbMinusB
        targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
        myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
        -- On Windows, mingw is distributed with GHC,
-       -- so we look in TopDir/../mingw/bin
+       -- so we look in TopDir/../mingw/bin,
+       -- as well as TopDir/../../mingw/bin for hadrian.
        -- It would perhaps be nice to be able to override this
        -- with the settings file, but it would be a little fiddly
        -- to make that possible, so for now you can't.
-       gcc_prog <- getSetting "C compiler command"
+       gcc_prog <- getToolSetting "C compiler command"
        gcc_args_str <- getSetting "C compiler flags"
        gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
-       cpp_prog <- getSetting "Haskell CPP command"
+       cpp_prog <- getToolSetting "Haskell CPP command"
        cpp_args_str <- getSetting "Haskell CPP flags"
        let unreg_gcc_args = if targetUnregisterised
                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
@@ -259,7 +212,7 @@ initSysTools mbMinusB
        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
        ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
        ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
-       perl_path <- getSetting "perl command"
+       perl_path <- getToolSetting "perl command"
 
        let pkgconfig_path = installed "package.conf.d"
            ghc_usage_msg_path  = installed "ghc-usage.txt"
@@ -272,12 +225,14 @@ initSysTools mbMinusB
              -- split is a Perl script
            split_script  = libexec cGHC_SPLIT_PGM
 
-       windres_path <- getSetting "windres command"
-       libtool_path <- getSetting "libtool command"
+       windres_path <- getToolSetting "windres command"
+       libtool_path <- getToolSetting "libtool command"
+       ar_path <- getToolSetting "ar command"
+       ranlib_path <- getToolSetting "ranlib command"
 
        tmpdir <- getTemporaryDirectory
 
-       touch_path <- getSetting "touch command"
+       touch_path <- getToolSetting "touch command"
 
        let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
            -- a call to Perl to get the invocation of split.
@@ -288,7 +243,7 @@ initSysTools mbMinusB
            (split_prog,  split_args)
              | isWindowsHost = (perl_path,    [Option split_script])
              | otherwise     = (split_script, [])
-       mkdll_prog <- getSetting "dllwrap command"
+       mkdll_prog <- getToolSetting "dllwrap command"
        let mkdll_args = []
 
        -- cpp is derived from gcc on all platforms
@@ -306,6 +261,7 @@ initSysTools mbMinusB
        -- We just assume on command line
        lc_prog <- getSetting "LLVM llc command"
        lo_prog <- getSetting "LLVM opt command"
+       lcc_prog <- getSetting "LLVM clang command"
 
        let iserv_prog = libexec "ghc-iserv"
 
@@ -325,6 +281,7 @@ initSysTools mbMinusB
                     sTmpDir         = normalise tmpdir,
                     sGhcUsagePath   = ghc_usage_msg_path,
                     sGhciUsagePath  = ghci_usage_msg_path,
+                    sToolDir        = mtool_dir,
                     sTopDir         = top_dir,
                     sRawSettings    = mySettings,
                     sExtraGccViaCFlags = words myExtraGccViaCFlags,
@@ -347,291 +304,27 @@ initSysTools mbMinusB
                     sPgm_T   = touch_path,
                     sPgm_windres = windres_path,
                     sPgm_libtool = libtool_path,
+                    sPgm_ar = ar_path,
+                    sPgm_ranlib = ranlib_path,
                     sPgm_lo  = (lo_prog,[]),
                     sPgm_lc  = (lc_prog,[]),
+                    sPgm_lcc = (lcc_prog,[]),
                     sPgm_i   = iserv_prog,
                     sOpt_L       = [],
                     sOpt_P       = [],
+                    sOpt_P_fingerprint = fingerprint0,
                     sOpt_F       = [],
                     sOpt_c       = [],
                     sOpt_a       = [],
                     sOpt_l       = [],
                     sOpt_windres = [],
+                    sOpt_lcc     = [],
                     sOpt_lo      = [],
                     sOpt_lc      = [],
                     sOpt_i       = [],
                     sPlatformConstants = platformConstants
              }
 
--- returns a Unix-format path (relying on getBaseDir to do so too)
-findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
-           -> IO String    -- TopDir (in Unix format '/' separated)
-findTopDir (Just minusb) = return (normalise minusb)
-findTopDir Nothing
-    = do -- Get directory of executable
-         maybe_exec_dir <- getBaseDir
-         case maybe_exec_dir of
-             -- "Just" on Windows, "Nothing" on unix
-             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
-             Just dir -> return dir
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Running an external program}
-*                                                                      *
-************************************************************************
--}
-
-runUnlit :: DynFlags -> [Option] -> IO ()
-runUnlit dflags args = do
-  let prog = pgm_L dflags
-      opts = getOpts dflags opt_L
-  runSomething dflags "Literate pre-processor" prog
-               (map Option opts ++ args)
-
-runCpp :: DynFlags -> [Option] -> IO ()
-runCpp dflags args =   do
-  let (p,args0) = pgm_P dflags
-      args1 = map Option (getOpts dflags opt_P)
-      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
-                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
-  mb_env <- getGccEnv args2
-  runSomethingFiltered dflags id  "C pre-processor" p
-                       (args0 ++ args1 ++ args2 ++ args) mb_env
-
-runPp :: DynFlags -> [Option] -> IO ()
-runPp dflags args =   do
-  let prog = pgm_F dflags
-      opts = map Option (getOpts dflags opt_F)
-  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
-
-runCc :: DynFlags -> [Option] -> IO ()
-runCc dflags args =   do
-  let (p,args0) = pgm_c dflags
-      args1 = map Option (getOpts dflags opt_c)
-      args2 = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
- where
-  -- discard some harmless warnings from gcc that we can't turn off
-  cc_filter = unlines . doFilter . lines
-
-  {-
-  gcc gives warnings in chunks like so:
-      In file included from /foo/bar/baz.h:11,
-                       from /foo/bar/baz2.h:22,
-                       from wibble.c:33:
-      /foo/flibble:14: global register variable ...
-      /foo/flibble:15: warning: call-clobbered r...
-  We break it up into its chunks, remove any call-clobbered register
-  warnings from each chunk, and then delete any chunks that we have
-  emptied of warnings.
-  -}
-  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
-  -- We can't assume that the output will start with an "In file inc..."
-  -- line, so we start off expecting a list of warnings rather than a
-  -- location stack.
-  chunkWarnings :: [String] -- The location stack to use for the next
-                            -- list of warnings
-                -> [String] -- The remaining lines to look at
-                -> [([String], [String])]
-  chunkWarnings loc_stack [] = [(loc_stack, [])]
-  chunkWarnings loc_stack xs
-      = case break loc_stack_start xs of
-        (warnings, lss:xs') ->
-            case span loc_start_continuation xs' of
-            (lsc, xs'') ->
-                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
-        _ -> [(loc_stack, xs)]
-
-  filterWarnings :: [([String], [String])] -> [([String], [String])]
-  filterWarnings [] = []
-  -- If the warnings are already empty then we are probably doing
-  -- something wrong, so don't delete anything
-  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
-  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
-                                       [] -> filterWarnings zs
-                                       ys' -> (xs, ys') : filterWarnings zs
-
-  unChunkWarnings :: [([String], [String])] -> [String]
-  unChunkWarnings [] = []
-  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
-
-  loc_stack_start        s = "In file included from " `isPrefixOf` s
-  loc_start_continuation s = "                 from " `isPrefixOf` s
-  wantedWarning w
-   | "warning: call-clobbered register used" `isContainedIn` w = False
-   | otherwise = True
-
-isContainedIn :: String -> String -> Bool
-xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
-
--- | Run the linker with some arguments and return the output
-askLd :: DynFlags -> [Option] -> IO String
-askLd dflags args = do
-  let (p,args0) = pgm_l dflags
-      args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingWith dflags "gcc" p args2 $ \real_args ->
-    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
-
--- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
--- inherited from the parent process, and output to stderr is not captured.
-readCreateProcessWithExitCode'
-    :: CreateProcess
-    -> IO (ExitCode, String)    -- ^ stdout
-readCreateProcessWithExitCode' proc = do
-    (_, Just outh, _, pid) <-
-        createProcess proc{ std_out = CreatePipe }
-
-    -- fork off a thread to start consuming the output
-    output  <- hGetContents outh
-    outMVar <- newEmptyMVar
-    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
-
-    -- wait on the output
-    takeMVar outMVar
-    hClose outh
-
-    -- wait on the process
-    ex <- waitForProcess pid
-
-    return (ex, output)
-
-replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
-replaceVar (var, value) env =
-    (var, value) : filter (\(var',_) -> var /= var') env
-
--- | Version of @System.Process.readProcessWithExitCode@ that takes a
--- key-value tuple to insert into the environment.
-readProcessEnvWithExitCode
-    :: String -- ^ program path
-    -> [String] -- ^ program args
-    -> (String, String) -- ^ addition to the environment
-    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
-readProcessEnvWithExitCode prog args env_update = do
-    current_env <- getEnvironment
-    readCreateProcessWithExitCode (proc prog args) {
-        env = Just (replaceVar env_update current_env) } ""
-
--- Don't let gcc localize version info string, #8825
-c_locale_env :: (String, String)
-c_locale_env = ("LANGUAGE", "C")
-
--- If the -B<dir> option is set, add <dir> to PATH.  This works around
--- a bug in gcc on Windows Vista where it can't find its auxiliary
--- binaries (see bug #1110).
-getGccEnv :: [Option] -> IO (Maybe [(String,String)])
-getGccEnv opts =
-  if null b_dirs
-     then return Nothing
-     else do env <- getEnvironment
-             return (Just (map mangle_path env))
- where
-  (b_dirs, _) = partitionWith get_b_opt opts
-
-  get_b_opt (Option ('-':'B':dir)) = Left dir
-  get_b_opt other = Right other
-
-  mangle_path (path,paths) | map toUpper path == "PATH"
-        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
-  mangle_path other = other
-
-runSplit :: DynFlags -> [Option] -> IO ()
-runSplit dflags args = do
-  let (p,args0) = pgm_s dflags
-  runSomething dflags "Splitter" p (args0++args)
-
-runAs :: DynFlags -> [Option] -> IO ()
-runAs dflags args = do
-  let (p,args0) = pgm_a dflags
-      args1 = map Option (getOpts dflags opt_a)
-      args2 = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingFiltered dflags id "Assembler" p args2 mb_env
-
--- | Run the LLVM Optimiser
-runLlvmOpt :: DynFlags -> [Option] -> IO ()
-runLlvmOpt dflags args = do
-  let (p,args0) = pgm_lo dflags
-      args1 = map Option (getOpts dflags opt_lo)
-  runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
-
--- | Run the LLVM Compiler
-runLlvmLlc :: DynFlags -> [Option] -> IO ()
-runLlvmLlc dflags args = do
-  let (p,args0) = pgm_lc dflags
-      args1 = map Option (getOpts dflags opt_lc)
-  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
-
--- | Run the clang compiler (used as an assembler for the LLVM
--- backend on OS X as LLVM doesn't support the OS X system
--- assembler)
-runClang :: DynFlags -> [Option] -> IO ()
-runClang dflags args = do
-  -- we simply assume its available on the PATH
-  let clang = "clang"
-      -- be careful what options we call clang with
-      -- see #5903 and #7617 for bugs caused by this.
-      (_,args0) = pgm_a dflags
-      args1 = map Option (getOpts dflags opt_a)
-      args2 = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  Exception.catch (do
-        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
-    )
-    (\(err :: SomeException) -> do
-        errorMsg dflags $
-            text ("Error running clang! you need clang installed to use the" ++
-                  " LLVM backend") $+$
-            text "(or GHC tried to execute clang incorrectly)"
-        throwIO err
-    )
-
--- | Figure out which version of LLVM we are running this session
-figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
-figureLlvmVersion dflags = do
-  let (pgm,opts) = pgm_lc dflags
-      args = filter notNull (map showOpt opts)
-      -- we grab the args even though they should be useless just in
-      -- case the user is using a customised 'llc' that requires some
-      -- of the options they've specified. llc doesn't care what other
-      -- options are specified when '-version' is used.
-      args' = args ++ ["-version"]
-  ver <- catchIO (do
-             (pin, pout, perr, _) <- runInteractiveProcess pgm args'
-                                             Nothing Nothing
-             {- > llc -version
-                  LLVM (http://llvm.org/):
-                    LLVM version 3.5.2
-                    ...
-             -}
-             hSetBinaryMode pout False
-             _     <- hGetLine pout
-             vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
-             v     <- case span (/= '.') vline of
-                        ("",_)  -> fail "no digits!"
-                        (x,y) -> return (read x
-                                        , read $ takeWhile isDigit $ drop 1 y)
-
-             hClose pin
-             hClose pout
-             hClose perr
-             return $ Just v
-            )
-            (\err -> do
-                debugTraceMsg dflags 2
-                    (text "Error (figuring out LLVM version):" <+>
-                     text (show err))
-                errorMsg dflags $ vcat
-                    [ text "Warning:", nest 9 $
-                          text "Couldn't figure out LLVM version!" $$
-                          text ("Make sure you have installed LLVM " ++
-                                llvmVersionStr supportedLlvmVersion) ]
-                return Nothing)
-  return ver
 
 {- Note [Windows stack usage]
 
@@ -664,340 +357,6 @@ for more information.
 
 -}
 
-{- Note [Run-time linker info]
-
-See also: Trac #5240, Trac #6063, Trac #10110
-
-Before 'runLink', we need to be sure to get the relevant information
-about the linker we're using at runtime to see if we need any extra
-options. For example, GNU ld requires '--reduce-memory-overheads' and
-'--hash-size=31' in order to use reasonable amounts of memory (see
-trac #5240.) But this isn't supported in GNU gold.
-
-Generally, the linker changing from what was detected at ./configure
-time has always been possible using -pgml, but on Linux it can happen
-'transparently' by installing packages like binutils-gold, which
-change what /usr/bin/ld actually points to.
-
-Clang vs GCC notes:
-
-For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
-invoke the linker before the version information string. For 'clang',
-the version information for 'ld' is all that's output. For this
-reason, we typically need to slurp up all of the standard error output
-and look through it.
-
-Other notes:
-
-We cache the LinkerInfo inside DynFlags, since clients may link
-multiple times. The definition of LinkerInfo is there to avoid a
-circular dependency.
-
--}
-
-{- Note [ELF needed shared libs]
-
-Some distributions change the link editor's default handling of
-ELF DT_NEEDED tags to include only those shared objects that are
-needed to resolve undefined symbols. For Template Haskell we need
-the last temporary shared library also if it is not needed for the
-currently linked temporary shared library. We specify --no-as-needed
-to override the default. This flag exists in GNU ld and GNU gold.
-
-The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
-(Mach-O) the flag is not needed.
-
--}
-
-{- Note [Windows static libGCC]
-
-The GCC versions being upgraded to in #10726 are configured with
-dynamic linking of libgcc supported. This results in libgcc being
-linked dynamically when a shared library is created.
-
-This introduces thus an extra dependency on GCC dll that was not
-needed before by shared libraries created with GHC. This is a particular
-issue on Windows because you get a non-obvious error due to this missing
-dependency. This dependent dll is also not commonly on your path.
-
-For this reason using the static libgcc is preferred as it preserves
-the same behaviour that existed before. There are however some very good
-reasons to have the shared version as well as described on page 181 of
-https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
-
-"There are several situations in which an application should use the
- shared ‘libgcc’ instead of the static version. The most common of these
- is when the application wishes to throw and catch exceptions across different
- shared libraries. In that case, each of the libraries as well as the application
- itself should use the shared ‘libgcc’. "
-
--}
-
-neededLinkArgs :: LinkerInfo -> [Option]
-neededLinkArgs (GnuLD o)     = o
-neededLinkArgs (GnuGold o)   = o
-neededLinkArgs (DarwinLD o)  = o
-neededLinkArgs (SolarisLD o) = o
-neededLinkArgs (AixLD o)     = o
-neededLinkArgs UnknownLD     = []
-
--- Grab linker info and cache it in DynFlags.
-getLinkerInfo :: DynFlags -> IO LinkerInfo
-getLinkerInfo dflags = do
-  info <- readIORef (rtldInfo dflags)
-  case info of
-    Just v  -> return v
-    Nothing -> do
-      v <- getLinkerInfo' dflags
-      writeIORef (rtldInfo dflags) (Just v)
-      return v
-
--- See Note [Run-time linker info].
-getLinkerInfo' :: DynFlags -> IO LinkerInfo
-getLinkerInfo' dflags = do
-  let platform = targetPlatform dflags
-      os = platformOS platform
-      (pgm,args0) = pgm_l dflags
-      args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ args1
-      args3     = filter notNull (map showOpt args2)
-
-      -- Try to grab the info from the process output.
-      parseLinkerInfo stdo _stde _exitc
-        | any ("GNU ld" `isPrefixOf`) stdo =
-          -- GNU ld specifically needs to use less memory. This especially
-          -- hurts on small object files. Trac #5240.
-          -- Set DT_NEEDED for all shared libraries. Trac #10110.
-          -- TODO: Investigate if these help or hurt when using split sections.
-          return (GnuLD $ map Option ["-Wl,--hash-size=31",
-                                      "-Wl,--reduce-memory-overheads",
-                                      -- ELF specific flag
-                                      -- see Note [ELF needed shared libs]
-                                      "-Wl,--no-as-needed"])
-
-        | any ("GNU gold" `isPrefixOf`) stdo =
-          -- GNU gold only needs --no-as-needed. Trac #10110.
-          -- ELF specific flag, see Note [ELF needed shared libs]
-          return (GnuGold [Option "-Wl,--no-as-needed"])
-
-         -- Unknown linker.
-        | otherwise = fail "invalid --version output, or linker is unsupported"
-
-  -- Process the executable call
-  info <- catchIO (do
-             case os of
-               OSSolaris2 ->
-                 -- Solaris uses its own Solaris linker. Even all
-                 -- GNU C are recommended to configure with Solaris
-                 -- linker instead of using GNU binutils linker. Also
-                 -- all GCC distributed with Solaris follows this rule
-                 -- precisely so we assume here, the Solaris linker is
-                 -- used.
-                 return $ SolarisLD []
-               OSAIX ->
-                 -- IBM AIX uses its own non-binutils linker as well
-                 return $ AixLD []
-               OSDarwin ->
-                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
-                 -- that doesn't support --version. We can just assume that's
-                 -- what we're using.
-                 return $ DarwinLD []
-               OSiOS ->
-                 -- Ditto for iOS
-                 return $ DarwinLD []
-               OSMinGW32 ->
-                 -- GHC doesn't support anything but GNU ld on Windows anyway.
-                 -- Process creation is also fairly expensive on win32, so
-                 -- we short-circuit here.
-                 return $ GnuLD $ map Option
-                   [ -- Reduce ld memory usage
-                     "-Wl,--hash-size=31"
-                   , "-Wl,--reduce-memory-overheads"
-                     -- Emit gcc stack checks
-                     -- Note [Windows stack usage]
-                   , "-fstack-check"
-                     -- Force static linking of libGCC
-                     -- Note [Windows static libGCC]
-                   , "-static-libgcc" ]
-               _ -> do
-                 -- In practice, we use the compiler as the linker here. Pass
-                 -- -Wl,--version to get linker version info.
-                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
-                                        (["-Wl,--version"] ++ args3)
-                                        c_locale_env
-                 -- Split the output by lines to make certain kinds
-                 -- of processing easier. In particular, 'clang' and 'gcc'
-                 -- have slightly different outputs for '-Wl,--version', but
-                 -- it's still easy to figure out.
-                 parseLinkerInfo (lines stdo) (lines stde) exitc
-            )
-            (\err -> do
-                debugTraceMsg dflags 2
-                    (text "Error (figuring out linker information):" <+>
-                     text (show err))
-                errorMsg dflags $ hang (text "Warning:") 9 $
-                  text "Couldn't figure out linker information!" $$
-                  text "Make sure you're using GNU ld, GNU gold" <+>
-                  text "or the built in OS X linker, etc."
-                return UnknownLD)
-  return info
-
--- Grab compiler info and cache it in DynFlags.
-getCompilerInfo :: DynFlags -> IO CompilerInfo
-getCompilerInfo dflags = do
-  info <- readIORef (rtccInfo dflags)
-  case info of
-    Just v  -> return v
-    Nothing -> do
-      v <- getCompilerInfo' dflags
-      writeIORef (rtccInfo dflags) (Just v)
-      return v
-
--- See Note [Run-time linker info].
-getCompilerInfo' :: DynFlags -> IO CompilerInfo
-getCompilerInfo' dflags = do
-  let (pgm,_) = pgm_c dflags
-      -- Try to grab the info from the process output.
-      parseCompilerInfo _stdo stde _exitc
-        -- Regular GCC
-        | any ("gcc version" `isInfixOf`) stde =
-          return GCC
-        -- Regular clang
-        | any ("clang version" `isInfixOf`) stde =
-          return Clang
-        -- XCode 5.1 clang
-        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
-          return AppleClang51
-        -- XCode 5 clang
-        | any ("Apple LLVM version" `isPrefixOf`) stde =
-          return AppleClang
-        -- XCode 4.1 clang
-        | any ("Apple clang version" `isPrefixOf`) stde =
-          return AppleClang
-         -- Unknown linker.
-        | otherwise = fail "invalid -v output, or compiler is unsupported"
-
-  -- Process the executable call
-  info <- catchIO (do
-                (exitc, stdo, stde) <-
-                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
-                -- Split the output by lines to make certain kinds
-                -- of processing easier.
-                parseCompilerInfo (lines stdo) (lines stde) exitc
-            )
-            (\err -> do
-                debugTraceMsg dflags 2
-                    (text "Error (figuring out C compiler information):" <+>
-                     text (show err))
-                errorMsg dflags $ hang (text "Warning:") 9 $
-                  text "Couldn't figure out C compiler information!" $$
-                  text "Make sure you're using GNU gcc, or clang"
-                return UnknownCC)
-  return info
-
-runLink :: DynFlags -> [Option] -> IO ()
-runLink dflags args = do
-  -- See Note [Run-time linker info]
-  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
-  let (p,args0) = pgm_l dflags
-      args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ linkargs ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
-  where
-    ld_filter = case (platformOS (targetPlatform dflags)) of
-                  OSSolaris2 -> sunos_ld_filter
-                  _ -> id
-{-
-  SunOS/Solaris ld emits harmless warning messages about unresolved
-  symbols in case of compiling into shared library when we do not
-  link against all the required libs. That is the case of GHC which
-  does not link against RTS library explicitly in order to be able to
-  choose the library later based on binary application linking
-  parameters. The warnings look like:
-
-Undefined                       first referenced
- symbol                             in file
-stg_ap_n_fast                       ./T2386_Lib.o
-stg_upd_frame_info                  ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
-newCAF                              ./T2386_Lib.o
-stg_bh_upd_frame_info               ./T2386_Lib.o
-stg_ap_ppp_fast                     ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
-stg_ap_p_fast                       ./T2386_Lib.o
-stg_ap_pp_fast                      ./T2386_Lib.o
-ld: warning: symbol referencing errors
-
-  this is actually coming from T2386 testcase. The emitting of those
-  warnings is also a reason why so many TH testcases fail on Solaris.
-
-  Following filter code is SunOS/Solaris linker specific and should
-  filter out only linker warnings. Please note that the logic is a
-  little bit more complex due to the simple reason that we need to preserve
-  any other linker emitted messages. If there are any. Simply speaking
-  if we see "Undefined" and later "ld: warning:..." then we omit all
-  text between (including) the marks. Otherwise we copy the whole output.
--}
-    sunos_ld_filter :: String -> String
-    sunos_ld_filter = unlines . sunos_ld_filter' . lines
-    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
-                         then (ld_prefix x) ++ (ld_postfix x)
-                         else x
-    breakStartsWith x y = break (isPrefixOf x) y
-    ld_prefix = fst . breakStartsWith "Undefined"
-    undefined_found = not . null . snd . breakStartsWith "Undefined"
-    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
-    ld_postfix = tail . snd . ld_warn_break
-    ld_warning_found = not . null . snd . ld_warn_break
-
-
-runLibtool :: DynFlags -> [Option] -> IO ()
-runLibtool dflags args = do
-  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
-  let args1      = map Option (getOpts dflags opt_l)
-      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
-      libtool    = pgm_libtool dflags
-  mb_env <- getGccEnv args2
-  runSomethingFiltered dflags id "Linker" libtool args2 mb_env
-
-runMkDLL :: DynFlags -> [Option] -> IO ()
-runMkDLL dflags args = do
-  let (p,args0) = pgm_dll dflags
-      args1 = args0 ++ args
-  mb_env <- getGccEnv (args0++args)
-  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
-
-runWindres :: DynFlags -> [Option] -> IO ()
-runWindres dflags args = do
-  let (gcc, gcc_args) = pgm_c dflags
-      windres = pgm_windres dflags
-      opts = map Option (getOpts dflags opt_windres)
-      quote x = "\"" ++ x ++ "\""
-      args' = -- If windres.exe and gcc.exe are in a directory containing
-              -- spaces then windres fails to run gcc. We therefore need
-              -- to tell it what command to use...
-              Option ("--preprocessor=" ++
-                      unwords (map quote (gcc :
-                                          map showOpt gcc_args ++
-                                          map showOpt opts ++
-                                          ["-E", "-xc", "-DRC_INVOKED"])))
-              -- ...but if we do that then if windres calls popen then
-              -- it can't understand the quoting, so we have to use
-              -- --use-temp-file so that it interprets it correctly.
-              -- See #1828.
-            : Option "--use-temp-file"
-            : args
-  mb_env <- getGccEnv gcc_args
-  runSomethingFiltered dflags id "Windres" windres args' mb_env
-
-touch :: DynFlags -> String -> String -> IO ()
-touch dflags purpose arg =
-  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
-
 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
 
@@ -1022,240 +381,6 @@ copyWithHeader dflags purpose maybe_header from to = do
    hPutStr h str
    hSetBinaryMode h True
 
------------------------------------------------------------------------------
--- Running an external program
-
-runSomething :: DynFlags
-             -> String          -- For -v message
-             -> String          -- Command name (possibly a full path)
-                                --      assumed already dos-ified
-             -> [Option]        -- Arguments
-                                --      runSomething will dos-ify them
-             -> IO ()
-
-runSomething dflags phase_name pgm args =
-  runSomethingFiltered dflags id phase_name pgm args Nothing
-
--- | Run a command, placing the arguments in an external response file.
---
--- This command is used in order to avoid overlong command line arguments on
--- Windows. The command line arguments are first written to an external,
--- temporary response file, and then passed to the linker via @filepath.
--- response files for passing them in. See:
---
---     https://gcc.gnu.org/wiki/Response_Files
---     https://ghc.haskell.org/trac/ghc/ticket/10777
-runSomethingResponseFile
-  :: DynFlags -> (String->String) -> String -> String -> [Option]
-  -> Maybe [(String,String)] -> IO ()
-
-runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
-    runSomethingWith dflags phase_name pgm args $ \real_args -> do
-        fp <- getResponseFile real_args
-        let args = ['@':fp]
-        r <- builderMainLoop dflags filter_fn pgm args mb_env
-        return (r,())
-  where
-    getResponseFile args = do
-      fp <- newTempName dflags TFL_CurrentModule "rsp"
-      withFile fp WriteMode $ \h -> do
-#if defined(mingw32_HOST_OS)
-          hSetEncoding h latin1
-#else
-          hSetEncoding h utf8
-#endif
-          hPutStr h $ unlines $ map escape args
-      return fp
-
-    -- Note: Response files have backslash-escaping, double quoting, and are
-    -- whitespace separated (some implementations use newline, others any
-    -- whitespace character). Therefore, escape any backslashes, newlines, and
-    -- double quotes in the argument, and surround the content with double
-    -- quotes.
-    --
-    -- Another possibility that could be considered would be to convert
-    -- backslashes in the argument to forward slashes. This would generally do
-    -- the right thing, since backslashes in general only appear in arguments
-    -- as part of file paths on Windows, and the forward slash is accepted for
-    -- those. However, escaping is more reliable, in case somehow a backslash
-    -- appears in a non-file.
-    escape x = concat
-        [ "\""
-        , concatMap
-            (\c ->
-                case c of
-                    '\\' -> "\\\\"
-                    '\n' -> "\\n"
-                    '\"' -> "\\\""
-                    _    -> [c])
-            x
-        , "\""
-        ]
-
-runSomethingFiltered
-  :: DynFlags -> (String->String) -> String -> String -> [Option]
-  -> Maybe [(String,String)] -> IO ()
-
-runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
-    runSomethingWith dflags phase_name pgm args $ \real_args -> do
-        r <- builderMainLoop dflags filter_fn pgm real_args mb_env
-        return (r,())
-
-runSomethingWith
-  :: DynFlags -> String -> String -> [Option]
-  -> ([String] -> IO (ExitCode, a))
-  -> IO a
-
-runSomethingWith dflags phase_name pgm args io = do
-  let real_args = filter notNull (map showOpt args)
-      cmdLine = showCommandForUser pgm real_args
-  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
-
-handleProc :: String -> String -> IO (ExitCode, r) -> IO r
-handleProc pgm phase_name proc = do
-    (rc, r) <- proc `catchIO` handler
-    case rc of
-      ExitSuccess{} -> return r
-      ExitFailure n -> throwGhcExceptionIO (
-            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
-                          " failed in phase `" ++ phase_name ++ "'." ++
-                          " (Exit code: " ++ show n ++ ")"))
-  where
-    handler err =
-       if IO.isDoesNotExistError err
-          then does_not_exist
-          else throwGhcExceptionIO (ProgramError $ show err)
-
-    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
-
-
-builderMainLoop :: DynFlags -> (String -> String) -> FilePath
-                -> [String] -> Maybe [(String, String)]
-                -> IO ExitCode
-builderMainLoop dflags filter_fn pgm real_args mb_env = do
-  chan <- newChan
-
-  -- We use a mask here rather than a bracket because we want
-  -- to distinguish between cleaning up with and without an
-  -- exception. This is to avoid calling terminateProcess
-  -- unless an exception was raised.
-  let safely inner = mask $ \restore -> do
-        -- acquire
-        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
-          runInteractiveProcess pgm real_args Nothing mb_env
-        let cleanup_handles = do
-              hClose hStdIn
-              hClose hStdOut
-              hClose hStdErr
-        r <- try $ restore $ do
-          hSetBuffering hStdOut LineBuffering
-          hSetBuffering hStdErr LineBuffering
-          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
-          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
-            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
-            inner hProcess
-        case r of
-          -- onException
-          Left (SomeException e) -> do
-            terminateProcess hProcess
-            cleanup_handles
-            throw e
-          -- cleanup when there was no exception
-          Right s -> do
-            cleanup_handles
-            return s
-  safely $ \h -> do
-    -- we don't want to finish until 2 streams have been complete
-    -- (stdout and stderr)
-    log_loop chan (2 :: Integer)
-    -- after that, we wait for the process to finish and return the exit code.
-    waitForProcess h
-  where
-    -- t starts at the number of streams we're listening to (2) decrements each
-    -- time a reader process sends EOF. We are safe from looping forever if a
-    -- reader thread dies, because they send EOF in a finally handler.
-    log_loop _ 0 = return ()
-    log_loop chan t = do
-      msg <- readChan chan
-      case msg of
-        BuildMsg msg -> do
-          putLogMsg dflags NoReason SevInfo noSrcSpan
-              (defaultUserStyle dflags) msg
-          log_loop chan t
-        BuildError loc msg -> do
-          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
-              (defaultUserStyle dflags) msg
-          log_loop chan t
-        EOF ->
-          log_loop chan  (t-1)
-
-readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
-readerProc chan hdl filter_fn =
-    (do str <- hGetContents hdl
-        loop (linesPlatform (filter_fn str)) Nothing)
-    `finally`
-       writeChan chan EOF
-        -- ToDo: check errors more carefully
-        -- ToDo: in the future, the filter should be implemented as
-        -- a stream transformer.
-    where
-        loop []     Nothing    = return ()
-        loop []     (Just err) = writeChan chan err
-        loop (l:ls) in_err     =
-                case in_err of
-                  Just err@(BuildError srcLoc msg)
-                    | leading_whitespace l -> do
-                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
-                    | otherwise -> do
-                        writeChan chan err
-                        checkError l ls
-                  Nothing -> do
-                        checkError l ls
-                  _ -> panic "readerProc/loop"
-
-        checkError l ls
-           = case parseError l of
-                Nothing -> do
-                    writeChan chan (BuildMsg (text l))
-                    loop ls Nothing
-                Just (file, lineNum, colNum, msg) -> do
-                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
-                    loop ls (Just (BuildError srcLoc (text msg)))
-
-        leading_whitespace []    = False
-        leading_whitespace (x:_) = isSpace x
-
-parseError :: String -> Maybe (String, Int, Int, String)
-parseError s0 = case breakColon s0 of
-                Just (filename, s1) ->
-                    case breakIntColon s1 of
-                    Just (lineNum, s2) ->
-                        case breakIntColon s2 of
-                        Just (columnNum, s3) ->
-                            Just (filename, lineNum, columnNum, s3)
-                        Nothing ->
-                            Just (filename, lineNum, 0, s2)
-                    Nothing -> Nothing
-                Nothing -> Nothing
-
-breakColon :: String -> Maybe (String, String)
-breakColon xs = case break (':' ==) xs of
-                    (ys, _:zs) -> Just (ys, zs)
-                    _ -> Nothing
-
-breakIntColon :: String -> Maybe (Int, String)
-breakIntColon xs = case break (':' ==) xs of
-                       (ys, _:zs)
-                        | not (null ys) && all isAscii ys && all isDigit ys ->
-                           Just (read ys, zs)
-                       _ -> Nothing
-
-data BuildMessage
-  = BuildMsg   !SDoc
-  | BuildError !SrcLoc !SDoc
-  | EOF
-
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1264,117 +389,6 @@ data BuildMessage
 ************************************************************************
 -}
 
------------------------------------------------------------------------------
--- Define       getBaseDir     :: IO (Maybe String)
-
-getBaseDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
--- Assuming we are running ghc, accessed by path  $(stuff)/<foo>/ghc.exe,
--- return the path $(stuff)/lib.
-getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
-  where
-    try_size size = allocaArray (fromIntegral size) $ \buf -> do
-        ret <- c_GetModuleFileName nullPtr buf size
-        case ret of
-          0 -> return Nothing
-          _ | ret < size -> do
-                path <- peekCWString buf
-                real <- getFinalPath path -- try to resolve symlinks paths
-                let libdir = (rootDir . sanitize . maybe path id) real
-                exists <- doesDirectoryExist libdir
-                if exists
-                   then return $ Just libdir
-                   else fail path
-            | otherwise  -> try_size (size * 2)
-
-    -- getFinalPath returns paths in full raw form.
-    -- Unfortunately GHC isn't set up to handle these
-    -- So if the call succeeded, we need to drop the
-    -- \\?\ prefix.
-    sanitize s = if "\\\\?\\" `isPrefixOf` s
-                    then drop 4 s
-                    else s
-
-    rootDir s = case splitFileName $ normalise s of
-                (d, ghc_exe)
-                 | lower ghc_exe `elem` ["ghc.exe",
-                                         "ghc-stage1.exe",
-                                         "ghc-stage2.exe",
-                                         "ghc-stage3.exe"] ->
-                    case splitFileName $ takeDirectory d of
-                    -- ghc is in $topdir/bin/ghc.exe
-                    (d', _) -> takeDirectory d' </> "lib"
-                _ -> fail s
-
-    fail s = panic ("can't decompose ghc.exe path: " ++ show s)
-    lower = map toLower
-
-foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
-  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
-
--- Attempt to resolve symlinks in order to find the actual location GHC
--- is located at. See Trac #11759.
-getFinalPath :: FilePath -> IO (Maybe FilePath)
-getFinalPath name = do
-    dllHwnd <- failIfNull "LoadLibrary"     $ loadLibrary "kernel32.dll"
-    -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
-    -- This means that we can't bind directly to it since it may be missing.
-    -- Instead try to find it's address at runtime and if we don't succeed consider the
-    -- function failed.
-    addr_m  <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
-                  `catch` (\(_ :: SomeException) -> return Nothing)
-    case addr_m of
-      Nothing   -> return Nothing
-      Just addr -> do handle  <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
-                                        $ createFile name
-                                                     gENERIC_READ
-                                                     fILE_SHARE_READ
-                                                     Nothing
-                                                     oPEN_EXISTING
-                                                     (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
-                                                     Nothing
-                      let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
-                      path    <- Win32.try "GetFinalPathName"
-                                    (\buf len -> fnPtr handle buf len 0) 512
-                                    `finally` closeHandle handle
-                      return $ Just path
-
-type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
-
-foreign import WINDOWS_CCONV unsafe "dynamic"
-  makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
-#else
-getBaseDir = return Nothing
-#endif
-
-
--- Divvy up text stream into lines, taking platform dependent
--- line termination into account.
-linesPlatform :: String -> [String]
-#if !defined(mingw32_HOST_OS)
-linesPlatform ls = lines ls
-#else
-linesPlatform "" = []
-linesPlatform xs =
-  case lineBreak xs of
-    (as,xs1) -> as : linesPlatform xs1
-  where
-   lineBreak "" = ("","")
-   lineBreak ('\r':'\n':xs) = ([],xs)
-   lineBreak ('\n':xs) = ([],xs)
-   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
-
-#endif
-
-{-
-Note [No PIE eating while linking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by
-default in their gcc builds. This is incompatible with -r as it implies that we
-are producing an executable. Consequently, we must manually pass -no-pie to gcc
-when joining object files or linking dynamic libraries. See #12759.
--}
-
 linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
 linkDynLib dflags0 o_files dep_packages
  = do
@@ -1465,7 +479,7 @@ linkDynLib dflags0 o_files dep_packages
                  ++ pkg_lib_path_opts
                  ++ pkg_link_opts
                 ))
-        _ | os `elem` [OSDarwin, OSiOS] -> do
+        _ | os == OSDarwin -> do
             -------------------------------------------------------------------
             -- Making a darwin dylib
             -------------------------------------------------------------------
@@ -1524,6 +538,7 @@ linkDynLib dflags0 o_files dep_packages
                  ++ map Option pkg_lib_path_opts
                  ++ map Option pkg_link_opts
                  ++ map Option pkg_framework_opts
+                 ++ [ Option "-Wl,-dead_strip_dylibs" ]
               )
         _ -> do
             -------------------------------------------------------------------
@@ -1531,19 +546,19 @@ linkDynLib dflags0 o_files dep_packages
             -------------------------------------------------------------------
 
             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+                unregisterised = platformUnregisterised (targetPlatform dflags)
             let bsymbolicFlag = -- we need symbolic linking to resolve
-                                -- non-PIC intra-package-relocations
-                                ["-Wl,-Bsymbolic"]
+                                -- non-PIC intra-package-relocations for
+                                -- performance (where symbolic linking works)
+                                -- See Note [-Bsymbolic assumptions by GHC]
+                                ["-Wl,-Bsymbolic" | not unregisterised]
 
             runLink dflags (
                     map Option verbFlags
+                 ++ libmLinkOpts
                  ++ [ Option "-o"
                     , FileOption "" output_fn
                     ]
-                    -- See Note [No PIE eating when linking]
-                 ++ (if sGccSupportsNoPie (settings dflags)
-                     then [Option "-no-pie"]
-                     else [])
                  ++ map Option o_files
                  ++ [ Option "-shared" ]
                  ++ map Option bsymbolicFlag
@@ -1556,6 +571,16 @@ linkDynLib dflags0 o_files dep_packages
                  ++ map Option pkg_link_opts
               )
 
+-- | Some platforms require that we explicitly link against @libm@ if any
+-- math-y things are used (which we assume to include all programs). See #14022.
+libmLinkOpts :: [Option]
+libmLinkOpts =
+#if defined(HAVE_LIBM)
+  [Option "-lm"]
+#else
+  []
+#endif
+
 getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
 getPkgFrameworkOpts dflags platform dep_packages
   | platformUsesFrameworks platform = do
@@ -1583,3 +608,27 @@ getFrameworkOpts dflags platform
     -- reverse because they're added in reverse order from the cmd line:
     framework_opts = concat [ ["-framework", fw]
                             | fw <- reverse frameworks ]
+
+{-
+Note [-Bsymbolic assumptions by GHC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC has a few assumptions about interaction of relocations in NCG and linker:
+
+1. -Bsymbolic resolves internal references when the shared library is linked,
+   which is important for performance.
+2. When there is a reference to data in a shared library from the main program,
+   the runtime linker relocates the data object into the main program using an
+   R_*_COPY relocation.
+3. If we used -Bsymbolic, then this results in multiple copies of the data
+   object, because some references have already been resolved to point to the
+   original instance. This is bad!
+
+We work around [3.] for native compiled code by avoiding the generation of
+R_*_COPY relocations.
+
+Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
+-Bsymbolic linking there.
+
+See related Trac tickets: #4210, #15338
+-}
diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs
new file mode 100644
index 0000000000..f858c8ffad
--- /dev/null
+++ b/compiler/main/SysTools/BaseDir.hs
@@ -0,0 +1,281 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2001-2017
+--
+-- Finding the compiler's base directory.
+--
+-----------------------------------------------------------------------------
+-}
+
+module SysTools.BaseDir
+  ( expandTopDir, expandToolDir
+  , findTopDir, findToolDir
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Panic
+
+import System.Environment (lookupEnv)
+import System.FilePath
+import Data.List
+
+-- POSIX
+#if defined(darwin_HOST_OS) || defined(linux_HOST_OS)
+import System.Environment (getExecutablePath)
+#endif
+
+-- Windows
+#if defined(mingw32_HOST_OS)
+#  if MIN_VERSION_Win32(2,5,0)
+#    if !MIN_VERSION_base(4,11,0)
+import qualified System.Win32.Types as Win32
+#    endif
+#  else
+import qualified System.Win32.Info as Win32
+#  endif
+#  if MIN_VERSION_base(4,11,0)
+import System.Environment (getExecutablePath)
+import System.Directory (doesDirectoryExist)
+#  else
+import Data.Char
+import Exception
+import Foreign
+import Foreign.C.String
+import System.Directory
+import System.Win32.Types (DWORD, LPTSTR, HANDLE)
+import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
+import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
+import System.Win32.DLL (loadLibrary, getProcAddress)
+#  endif
+#endif
+
+#if defined(mingw32_HOST_OS)
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
+
+{-
+Note [topdir: How GHC finds its files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC needs various support files (library packages, RTS etc), plus
+various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
+the root of GHC's support files
+
+On Unix:
+  - ghc always has a shell wrapper that passes a -B<dir> option
+
+On Windows:
+  - ghc never has a shell wrapper.
+  - we can find the location of the ghc binary, which is
+        $topdir/<foo>/<something>.exe
+    where <something> may be "ghc", "ghc-stage2", or similar
+  - we strip off the "<foo>/<something>.exe" to leave $topdir.
+
+from topdir we can find package.conf, ghc-asm, etc.
+
+
+Note [tooldir: How GHC finds mingw and perl on Windows]
+
+GHC has some custom logic on Windows for finding the mingw
+toolchain and perl. Depending on whether GHC is built
+with the make build system or Hadrian, and on whether we're
+running a bindist, we might find the mingw toolchain and perl
+either under $topdir/../{mingw, perl}/ or
+$topdir/../../{mingw, perl}/.
+
+-}
+
+-- | Expand occurrences of the @$topdir@ interpolation in a string.
+expandTopDir :: FilePath -> String -> String
+expandTopDir = expandPathVar "topdir"
+
+-- | Expand occurrences of the @$tooldir@ interpolation in a string
+-- on Windows, leave the string untouched otherwise.
+expandToolDir :: Maybe FilePath -> String -> String
+#if defined(mingw32_HOST_OS)
+expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
+expandToolDir Nothing         _ = panic "Could not determine $tooldir"
+#else
+expandToolDir _ s = s
+#endif
+
+-- | @expandPathVar var value str@
+--
+--   replaces occurences of variable @$var@ with @value@ in str.
+expandPathVar :: String -> FilePath -> String -> String
+expandPathVar var value str
+  | Just str' <- stripPrefix ('$':var) str
+  , null str' || isPathSeparator (head str')
+  = value ++ expandPathVar var value str'
+expandPathVar var value (x:xs) = x : expandPathVar var value xs
+expandPathVar _ _ [] = []
+
+-- | Returns a Unix-format path pointing to TopDir.
+findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
+           -> IO String    -- TopDir (in Unix format '/' separated)
+findTopDir (Just minusb) = return (normalise minusb)
+findTopDir Nothing
+    = do -- The _GHC_TOP_DIR environment variable can be used to specify
+         -- the top dir when the -B argument is not specified. It is not
+         -- intended for use by users, it was added specifically for the
+         -- purpose of running GHC within GHCi.
+         maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR"
+         case maybe_env_top_dir of
+             Just env_top_dir -> return env_top_dir
+             Nothing -> do
+                 -- Get directory of executable
+                 maybe_exec_dir <- getBaseDir
+                 case maybe_exec_dir of
+                     -- "Just" on Windows, "Nothing" on unix
+                     Nothing -> throwGhcExceptionIO $
+                         InstallationError "missing -B<dir> option"
+                     Just dir -> return dir
+
+getBaseDir :: IO (Maybe String)
+
+#if defined(mingw32_HOST_OS)
+
+-- locate the "base dir" when given the path
+-- to the real ghc executable (as opposed to symlink)
+-- that is running this function.
+rootDir :: FilePath -> FilePath
+rootDir = takeDirectory . takeDirectory . normalise
+
+#if MIN_VERSION_base(4,11,0)
+getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
+#else
+-- Assuming we are running ghc, accessed by path  $(stuff)/<foo>/ghc.exe,
+-- return the path $(stuff)/lib.
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> do
+                path <- peekCWString buf
+                real <- getFinalPath path -- try to resolve symlinks paths
+                let libdir = (buildLibDir . sanitize . maybe path id) real
+                exists <- doesDirectoryExist libdir
+                if exists
+                   then return $ Just libdir
+                   else fail path
+            | otherwise  -> try_size (size * 2)
+
+    -- getFinalPath returns paths in full raw form.
+    -- Unfortunately GHC isn't set up to handle these
+    -- So if the call succeeded, we need to drop the
+    -- \\?\ prefix.
+    sanitize s = if "\\\\?\\" `isPrefixOf` s
+                    then drop 4 s
+                    else s
+
+    buildLibDir :: FilePath -> FilePath
+    buildLibDir s =
+      (takeDirectory . takeDirectory . normalise $ s) </> "lib"
+
+    fail s = panic ("can't decompose ghc.exe path: " ++ show s)
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+
+-- Attempt to resolve symlinks in order to find the actual location GHC
+-- is located at. See Trac #11759.
+getFinalPath :: FilePath -> IO (Maybe FilePath)
+getFinalPath name = do
+    dllHwnd <- failIfNull "LoadLibrary"     $ loadLibrary "kernel32.dll"
+    -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
+    -- This means that we can't bind directly to it since it may be missing.
+    -- Instead try to find it's address at runtime and if we don't succeed consider the
+    -- function failed.
+    addr_m  <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
+                  `catch` (\(_ :: SomeException) -> return Nothing)
+    case addr_m of
+      Nothing   -> return Nothing
+      Just addr -> do handle  <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
+                                        $ createFile name
+                                                     gENERIC_READ
+                                                     fILE_SHARE_READ
+                                                     Nothing
+                                                     oPEN_EXISTING
+                                                     (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
+                                                     Nothing
+                      let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
+                      -- First try to resolve the path to get the actual path
+                      -- of any symlinks or other file system redirections that
+                      -- may be in place. However this function can fail, and in
+                      -- the event it does fail, we need to try using the
+                      -- original path and see if we can decompose that.
+                      -- If the call fails Win32.try will raise an exception
+                      -- that needs to be caught. See #14159
+                      path    <- (Win32.try "GetFinalPathName"
+                                    (\buf len -> fnPtr handle buf len 0) 512
+                                    `finally` closeHandle handle)
+                                `catch`
+                                 (\(_ :: IOException) -> return name)
+                      return $ Just path
+
+type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
+
+foreign import WINDOWS_CCONV unsafe "dynamic"
+  makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
+#endif
+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
+-- on unix, this is a bit more confusing.
+-- The layout right now is something like
+--
+--   /bin/ghc-X.Y.Z <- wrapper script (1)
+--   /bin/ghc       <- symlink to wrapper script (2)
+--   /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3)
+--   /lib/ghc-X.Y.Z <- $topdir (4)
+--
+-- As such, we first need to find the absolute location to the
+-- binary.
+--
+-- getExecutablePath will return (3). One takeDirectory will
+-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4).
+--
+-- This of course only works due to the current layout. If
+-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib}
+-- this would need to be changed accordingly.
+--
+getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
+#else
+getBaseDir = return Nothing
+#endif
+
+-- See Note [tooldir: How GHC finds mingw and perl on Windows]
+-- Returns @Nothing@ when not on Windows.
+-- When called on Windows, it either throws an error when the
+-- tooldir can't be located, or returns @Just tooldirpath@.
+findToolDir
+  :: FilePath -- ^ topdir
+  -> IO (Maybe FilePath)
+#if defined(mingw32_HOST_OS)
+findToolDir top_dir = go 0 (top_dir </> "..")
+  where maxDepth = 3
+        go :: Int -> FilePath -> IO (Maybe FilePath)
+        go k path
+          | k == maxDepth = throwGhcExceptionIO $
+              InstallationError "could not detect mingw toolchain"
+          | otherwise = do
+              oneLevel <- doesDirectoryExist (path </> "mingw")
+              if oneLevel
+                then return (Just path)
+                else go (k+1) (path </> "..")
+#else
+findToolDir _ = return Nothing
+#endif
diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs
new file mode 100644
index 0000000000..bbcb1b6a7a
--- /dev/null
+++ b/compiler/main/SysTools/ExtraObj.hs
@@ -0,0 +1,239 @@
+-----------------------------------------------------------------------------
+--
+-- GHC Extra object linking code
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+
+module SysTools.ExtraObj (
+  mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
+  checkLinkInfo, getLinkInfo, getCompilerInfo,
+  ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,
+  haveRtsOptsFlags
+) where
+
+import AsmUtils
+import ErrUtils
+import DynFlags
+import Packages
+import Platform
+import Outputable
+import SrcLoc           ( noSrcSpan )
+import Module
+import Elf
+import Util
+import GhcPrelude
+
+import Control.Monad
+import Data.Maybe
+
+import Control.Monad.IO.Class
+
+import FileCleanup
+import SysTools.Tasks
+import SysTools.Info
+
+mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
+mkExtraObj dflags extn xs
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+      oFile <- newTempName dflags TFL_GhcSession "o"
+      writeFile cFile xs
+      ccInfo <- liftIO $ getCompilerInfo dflags
+      runCc dflags
+            ([Option        "-c",
+              FileOption "" cFile,
+              Option        "-o",
+              FileOption "" oFile]
+              ++ if extn /= "s"
+                    then cOpts
+                    else asmOpts ccInfo)
+      return oFile
+    where
+      -- Pass a different set of options to the C compiler depending one whether
+      -- we're compiling C or assembler. When compiling C, we pass the usual
+      -- set of include directories and PIC flags.
+      cOpts = map Option (picCCOpts dflags)
+                    ++ map (FileOption "-I")
+                            (includeDirs $ getPackageDetails dflags rtsUnitId)
+
+      -- When compiling assembler code, we drop the usual C options, and if the
+      -- compiler is Clang, we add an extra argument to tell Clang to ignore
+      -- unused command line options. See trac #11684.
+      asmOpts ccInfo =
+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                then [Option "-Qunused-arguments"]
+                else []
+
+-- When linking a binary, we need to create a C main() function that
+-- starts everything off.  This used to be compiled statically as part
+-- of the RTS, but that made it hard to change the -rtsopts setting,
+-- so now we generate and compile a main() stub as part of every
+-- binary and pass the -rtsopts setting directly to the RTS (#5373)
+--
+-- On Windows, when making a shared library we also may need a DllMain.
+--
+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
+mkExtraObjToLinkIntoBinary dflags = do
+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
+     putLogMsg dflags NoReason SevInfo noSrcSpan
+         (defaultUserStyle dflags)
+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
+          text "    Call hs_init_ghc() from your main() function to set these options.")
+
+  mkExtraObj dflags "c" (showSDoc dflags main)
+  where
+    main
+      | gopt Opt_NoHsMain dflags = Outputable.empty
+      | otherwise
+          = case ghcLink dflags of
+                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32
+                                    then dllMain
+                                    else Outputable.empty
+                  _                      -> exeMain
+
+    exeMain = vcat [
+        text "#include \"Rts.h\"",
+        text "extern StgClosure ZCMain_main_closure;",
+        text "int main(int argc, char *argv[])",
+        char '{',
+        text " RtsConfig __conf = defaultRtsConfig;",
+        text " __conf.rts_opts_enabled = "
+            <> text (show (rtsOptsEnabled dflags)) <> semi,
+        text " __conf.rts_opts_suggestions = "
+            <> text (if rtsOptsSuggestions dflags
+                        then "true"
+                        else "false") <> semi,
+        case rtsOpts dflags of
+            Nothing   -> Outputable.empty
+            Just opts -> text "    __conf.rts_opts= " <>
+                          text (show opts) <> semi,
+        text " __conf.rts_hs_main = true;",
+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
+        char '}',
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+    dllMain = vcat [
+        text "#include \"Rts.h\"",
+        text "#include <windows.h>",
+        text "#include <stdbool.h>",
+        char '\n',
+        text "bool",
+        text "WINAPI",
+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",
+        text "        , DWORD reason STG_UNUSED",
+        text "        , LPVOID reserved STG_UNUSED",
+        text "        )",
+        text "{",
+        text "  return true;",
+        text "}",
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+-- Write out the link info section into a new assembly file. Previously
+-- this was included as inline assembly in the main.c file but this
+-- is pretty fragile. gas gets upset trying to calculate relative offsets
+-- that span the .note section (notably .text) when debug info is present
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary dflags dep_packages = do
+   link_info <- getLinkInfo dflags dep_packages
+
+   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
+     else return []
+
+  where
+    link_opts info = hcat [
+      -- "link info" section (see Note [LinkInfo section])
+      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,
+
+      -- ALL generated assembly must have this section to disable
+      -- executable stacks.  See also
+      -- compiler/nativeGen/AsmCodeGen.hs for another instance
+      -- where we need to do this.
+      if platformHasGnuNonexecStack (targetPlatform dflags)
+        then text ".section .note.GNU-stack,\"\","
+             <> sectionType "progbits" <> char '\n'
+        else Outputable.empty
+      ]
+
+-- | Return the "link info" string
+--
+-- See Note [LinkInfo section]
+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
+getLinkInfo dflags dep_packages = do
+   package_link_opts <- getPackageLinkOpts dflags dep_packages
+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
+                     then getPackageFrameworks dflags dep_packages
+                     else return []
+   let extra_ld_inputs = ldInputs dflags
+   let
+      link_info = (package_link_opts,
+                   pkg_frameworks,
+                   rtsOpts dflags,
+                   rtsOptsEnabled dflags,
+                   gopt Opt_NoHsMain dflags,
+                   map showOpt extra_ld_inputs,
+                   getOpts dflags opt_l)
+   --
+   return (show link_info)
+
+platformSupportsSavingLinkOpts :: OS -> Bool
+platformSupportsSavingLinkOpts os
+ | os == OSSolaris2 = False -- see #5382
+ | otherwise        = osElfTarget os
+
+-- See Note [LinkInfo section]
+ghcLinkInfoSectionName :: String
+ghcLinkInfoSectionName = ".debug-ghc-link-info"
+  -- if we use the ".debug" prefix, then strip will strip it by default
+
+-- Identifier for the note (see Note [LinkInfo section])
+ghcLinkInfoNoteName :: String
+ghcLinkInfoNoteName = "GHC link info"
+
+-- Returns 'False' if it was, and we can avoid linking, because the
+-- previous binary was linked with "the same options".
+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
+checkLinkInfo dflags pkg_deps exe_file
+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+ -- ToDo: Windows and OS X do not use the ELF binary format, so
+ -- readelf does not work there.  We need to find another way to do
+ -- this.
+ = return False -- conservatively we should return True, but not
+                -- linking in this case was the behaviour for a long
+                -- time so we leave it as-is.
+ | otherwise
+ = do
+   link_info <- getLinkInfo dflags pkg_deps
+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
+   m_exe_link_info <- readElfNoteAsString dflags exe_file
+                          ghcLinkInfoSectionName ghcLinkInfoNoteName
+   let sameLinkInfo = (Just link_info == m_exe_link_info)
+   debugTraceMsg dflags 3 $ case m_exe_link_info of
+     Nothing -> text "Exe link info: Not found"
+     Just s
+       | sameLinkInfo -> text ("Exe link info is the same")
+       | otherwise    -> text ("Exe link info is different: " ++ s)
+   return (not sameLinkInfo)
+
+{- Note [LinkInfo section]
+   ~~~~~~~~~~~~~~~~~~~~~~~
+
+The "link info" is a string representing the parameters of the link. We save
+this information in the binary, and the next time we link, if nothing else has
+changed, we use the link info stored in the existing binary to decide whether
+to re-link or not.
+
+The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
+not follow the specified record-based format (see #11022).
+
+-}
+
+haveRtsOptsFlags :: DynFlags -> Bool
+haveRtsOptsFlags dflags =
+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
+                                       RtsOptsSafeOnly -> False
+                                       _ -> True
diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs
new file mode 100644
index 0000000000..6b310578ff
--- /dev/null
+++ b/compiler/main/SysTools/Info.hs
@@ -0,0 +1,260 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Compiler information functions
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Info where
+
+import Exception
+import ErrUtils
+import DynFlags
+import Outputable
+import Util
+
+import Data.List
+import Data.IORef
+
+import System.IO
+
+import Platform
+import GhcPrelude
+
+import SysTools.Process
+
+{- Note [Run-time linker info]
+
+See also: Trac #5240, Trac #6063, Trac #10110
+
+Before 'runLink', we need to be sure to get the relevant information
+about the linker we're using at runtime to see if we need any extra
+options. For example, GNU ld requires '--reduce-memory-overheads' and
+'--hash-size=31' in order to use reasonable amounts of memory (see
+trac #5240.) But this isn't supported in GNU gold.
+
+Generally, the linker changing from what was detected at ./configure
+time has always been possible using -pgml, but on Linux it can happen
+'transparently' by installing packages like binutils-gold, which
+change what /usr/bin/ld actually points to.
+
+Clang vs GCC notes:
+
+For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
+invoke the linker before the version information string. For 'clang',
+the version information for 'ld' is all that's output. For this
+reason, we typically need to slurp up all of the standard error output
+and look through it.
+
+Other notes:
+
+We cache the LinkerInfo inside DynFlags, since clients may link
+multiple times. The definition of LinkerInfo is there to avoid a
+circular dependency.
+
+-}
+
+{- Note [ELF needed shared libs]
+
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+
+-}
+
+{- Note [Windows static libGCC]
+
+The GCC versions being upgraded to in #10726 are configured with
+dynamic linking of libgcc supported. This results in libgcc being
+linked dynamically when a shared library is created.
+
+This introduces thus an extra dependency on GCC dll that was not
+needed before by shared libraries created with GHC. This is a particular
+issue on Windows because you get a non-obvious error due to this missing
+dependency. This dependent dll is also not commonly on your path.
+
+For this reason using the static libgcc is preferred as it preserves
+the same behaviour that existed before. There are however some very good
+reasons to have the shared version as well as described on page 181 of
+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
+
+"There are several situations in which an application should use the
+ shared ‘libgcc’ instead of the static version. The most common of these
+ is when the application wishes to throw and catch exceptions across different
+ shared libraries. In that case, each of the libraries as well as the application
+ itself should use the shared ‘libgcc’. "
+
+-}
+
+neededLinkArgs :: LinkerInfo -> [Option]
+neededLinkArgs (GnuLD o)     = o
+neededLinkArgs (GnuGold o)   = o
+neededLinkArgs (LlvmLLD o)   = o
+neededLinkArgs (DarwinLD o)  = o
+neededLinkArgs (SolarisLD o) = o
+neededLinkArgs (AixLD o)     = o
+neededLinkArgs UnknownLD     = []
+
+-- Grab linker info and cache it in DynFlags.
+getLinkerInfo :: DynFlags -> IO LinkerInfo
+getLinkerInfo dflags = do
+  info <- readIORef (rtldInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getLinkerInfo' dflags
+      writeIORef (rtldInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getLinkerInfo' :: DynFlags -> IO LinkerInfo
+getLinkerInfo' dflags = do
+  let platform = targetPlatform dflags
+      os = platformOS platform
+      (pgm,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1
+      args3     = filter notNull (map showOpt args2)
+
+      -- Try to grab the info from the process output.
+      parseLinkerInfo stdo _stde _exitc
+        | any ("GNU ld" `isPrefixOf`) stdo =
+          -- GNU ld specifically needs to use less memory. This especially
+          -- hurts on small object files. Trac #5240.
+          -- Set DT_NEEDED for all shared libraries. Trac #10110.
+          -- TODO: Investigate if these help or hurt when using split sections.
+          return (GnuLD $ map Option ["-Wl,--hash-size=31",
+                                      "-Wl,--reduce-memory-overheads",
+                                      -- ELF specific flag
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
+
+        | any ("GNU gold" `isPrefixOf`) stdo =
+          -- GNU gold only needs --no-as-needed. Trac #10110.
+          -- ELF specific flag, see Note [ELF needed shared libs]
+          return (GnuGold [Option "-Wl,--no-as-needed"])
+
+        | any ("LLD" `isPrefixOf`) stdo =
+          return (LlvmLLD [])
+
+         -- Unknown linker.
+        | otherwise = fail "invalid --version output, or linker is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+             case os of
+               OSSolaris2 ->
+                 -- Solaris uses its own Solaris linker. Even all
+                 -- GNU C are recommended to configure with Solaris
+                 -- linker instead of using GNU binutils linker. Also
+                 -- all GCC distributed with Solaris follows this rule
+                 -- precisely so we assume here, the Solaris linker is
+                 -- used.
+                 return $ SolarisLD []
+               OSAIX ->
+                 -- IBM AIX uses its own non-binutils linker as well
+                 return $ AixLD []
+               OSDarwin ->
+                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
+                 -- that doesn't support --version. We can just assume that's
+                 -- what we're using.
+                 return $ DarwinLD []
+               OSMinGW32 ->
+                 -- GHC doesn't support anything but GNU ld on Windows anyway.
+                 -- Process creation is also fairly expensive on win32, so
+                 -- we short-circuit here.
+                 return $ GnuLD $ map Option
+                   [ -- Reduce ld memory usage
+                     "-Wl,--hash-size=31"
+                   , "-Wl,--reduce-memory-overheads"
+                     -- Emit gcc stack checks
+                     -- Note [Windows stack usage]
+                   , "-fstack-check"
+                     -- Force static linking of libGCC
+                     -- Note [Windows static libGCC]
+                   , "-static-libgcc" ]
+               _ -> do
+                 -- In practice, we use the compiler as the linker here. Pass
+                 -- -Wl,--version to get linker version info.
+                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
+                                        (["-Wl,--version"] ++ args3)
+                                        c_locale_env
+                 -- Split the output by lines to make certain kinds
+                 -- of processing easier. In particular, 'clang' and 'gcc'
+                 -- have slightly different outputs for '-Wl,--version', but
+                 -- it's still easy to figure out.
+                 parseLinkerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out linker information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out linker information!" $$
+                  text "Make sure you're using GNU ld, GNU gold" <+>
+                  text "or the built in OS X linker, etc."
+                return UnknownLD)
+  return info
+
+-- Grab compiler info and cache it in DynFlags.
+getCompilerInfo :: DynFlags -> IO CompilerInfo
+getCompilerInfo dflags = do
+  info <- readIORef (rtccInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getCompilerInfo' dflags
+      writeIORef (rtccInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getCompilerInfo' :: DynFlags -> IO CompilerInfo
+getCompilerInfo' dflags = do
+  let (pgm,_) = pgm_c dflags
+      -- Try to grab the info from the process output.
+      parseCompilerInfo _stdo stde _exitc
+        -- Regular GCC
+        | any ("gcc version" `isInfixOf`) stde =
+          return GCC
+        -- Regular clang
+        | any ("clang version" `isInfixOf`) stde =
+          return Clang
+        -- FreeBSD clang
+        | any ("FreeBSD clang version" `isInfixOf`) stde =
+          return Clang
+        -- XCode 5.1 clang
+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
+          return AppleClang51
+        -- XCode 5 clang
+        | any ("Apple LLVM version" `isPrefixOf`) stde =
+          return AppleClang
+        -- XCode 4.1 clang
+        | any ("Apple clang version" `isPrefixOf`) stde =
+          return AppleClang
+         -- Unknown linker.
+        | otherwise = fail "invalid -v output, or compiler is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+                (exitc, stdo, stde) <-
+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
+                -- Split the output by lines to make certain kinds
+                -- of processing easier.
+                parseCompilerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out C compiler information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out C compiler information!" $$
+                  text "Make sure you're using GNU gcc, or clang"
+                return UnknownCC)
+  return info
diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs
new file mode 100644
index 0000000000..cc8f67d139
--- /dev/null
+++ b/compiler/main/SysTools/Process.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+--
+-- Misc process handling code for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Process where
+
+#include "HsVersions.h"
+
+import Exception
+import ErrUtils
+import DynFlags
+import FastString
+import Outputable
+import Panic
+import GhcPrelude
+import Util
+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
+
+import Control.Concurrent
+import Data.Char
+
+import System.Exit
+import System.Environment
+import System.FilePath
+import System.IO
+import System.IO.Error as IO
+import System.Process
+
+import FileCleanup
+
+-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
+-- inherited from the parent process, and output to stderr is not captured.
+readCreateProcessWithExitCode'
+    :: CreateProcess
+    -> IO (ExitCode, String)    -- ^ stdout
+readCreateProcessWithExitCode' proc = do
+    (_, Just outh, _, pid) <-
+        createProcess proc{ std_out = CreatePipe }
+
+    -- fork off a thread to start consuming the output
+    output  <- hGetContents outh
+    outMVar <- newEmptyMVar
+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+
+    -- wait on the output
+    takeMVar outMVar
+    hClose outh
+
+    -- wait on the process
+    ex <- waitForProcess pid
+
+    return (ex, output)
+
+replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
+replaceVar (var, value) env =
+    (var, value) : filter (\(var',_) -> var /= var') env
+
+-- | Version of @System.Process.readProcessWithExitCode@ that takes a
+-- key-value tuple to insert into the environment.
+readProcessEnvWithExitCode
+    :: String -- ^ program path
+    -> [String] -- ^ program args
+    -> (String, String) -- ^ addition to the environment
+    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
+readProcessEnvWithExitCode prog args env_update = do
+    current_env <- getEnvironment
+    readCreateProcessWithExitCode (proc prog args) {
+        env = Just (replaceVar env_update current_env) } ""
+
+-- Don't let gcc localize version info string, #8825
+c_locale_env :: (String, String)
+c_locale_env = ("LANGUAGE", "C")
+
+-- If the -B<dir> option is set, add <dir> to PATH.  This works around
+-- a bug in gcc on Windows Vista where it can't find its auxiliary
+-- binaries (see bug #1110).
+getGccEnv :: [Option] -> IO (Maybe [(String,String)])
+getGccEnv opts =
+  if null b_dirs
+     then return Nothing
+     else do env <- getEnvironment
+             return (Just (map mangle_path env))
+ where
+  (b_dirs, _) = partitionWith get_b_opt opts
+
+  get_b_opt (Option ('-':'B':dir)) = Left dir
+  get_b_opt other = Right other
+
+  mangle_path (path,paths) | map toUpper path == "PATH"
+        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
+  mangle_path other = other
+
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+runSomething :: DynFlags
+             -> String          -- For -v message
+             -> String          -- Command name (possibly a full path)
+                                --      assumed already dos-ified
+             -> [Option]        -- Arguments
+                                --      runSomething will dos-ify them
+             -> IO ()
+
+runSomething dflags phase_name pgm args =
+  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing
+
+-- | Run a command, placing the arguments in an external response file.
+--
+-- This command is used in order to avoid overlong command line arguments on
+-- Windows. The command line arguments are first written to an external,
+-- temporary response file, and then passed to the linker via @filepath.
+-- response files for passing them in. See:
+--
+--     https://gcc.gnu.org/wiki/Response_Files
+--     https://ghc.haskell.org/trac/ghc/ticket/10777
+runSomethingResponseFile
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
+
+runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        fp <- getResponseFile real_args
+        let args = ['@':fp]
+        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
+        return (r,())
+  where
+    getResponseFile args = do
+      fp <- newTempName dflags TFL_CurrentModule "rsp"
+      withFile fp WriteMode $ \h -> do
+#if defined(mingw32_HOST_OS)
+          hSetEncoding h latin1
+#else
+          hSetEncoding h utf8
+#endif
+          hPutStr h $ unlines $ map escape args
+      return fp
+
+    -- Note: Response files have backslash-escaping, double quoting, and are
+    -- whitespace separated (some implementations use newline, others any
+    -- whitespace character). Therefore, escape any backslashes, newlines, and
+    -- double quotes in the argument, and surround the content with double
+    -- quotes.
+    --
+    -- Another possibility that could be considered would be to convert
+    -- backslashes in the argument to forward slashes. This would generally do
+    -- the right thing, since backslashes in general only appear in arguments
+    -- as part of file paths on Windows, and the forward slash is accepted for
+    -- those. However, escaping is more reliable, in case somehow a backslash
+    -- appears in a non-file.
+    escape x = concat
+        [ "\""
+        , concatMap
+            (\c ->
+                case c of
+                    '\\' -> "\\\\"
+                    '\n' -> "\\n"
+                    '\"' -> "\\\""
+                    _    -> [c])
+            x
+        , "\""
+        ]
+
+runSomethingFiltered
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
+
+runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
+        return (r,())
+
+runSomethingWith
+  :: DynFlags -> String -> String -> [Option]
+  -> ([String] -> IO (ExitCode, a))
+  -> IO a
+
+runSomethingWith dflags phase_name pgm args io = do
+  let real_args = filter notNull (map showOpt args)
+      cmdLine = showCommandForUser pgm real_args
+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
+
+handleProc :: String -> String -> IO (ExitCode, r) -> IO r
+handleProc pgm phase_name proc = do
+    (rc, r) <- proc `catchIO` handler
+    case rc of
+      ExitSuccess{} -> return r
+      ExitFailure n -> throwGhcExceptionIO (
+            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
+                          " failed in phase `" ++ phase_name ++ "'." ++
+                          " (Exit code: " ++ show n ++ ")"))
+  where
+    handler err =
+       if IO.isDoesNotExistError err
+          then does_not_exist
+          else throwGhcExceptionIO (ProgramError $ show err)
+
+    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
+
+
+builderMainLoop :: DynFlags -> (String -> String) -> FilePath
+                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
+                -> IO ExitCode
+builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
+  chan <- newChan
+
+  -- We use a mask here rather than a bracket because we want
+  -- to distinguish between cleaning up with and without an
+  -- exception. This is to avoid calling terminateProcess
+  -- unless an exception was raised.
+  let safely inner = mask $ \restore -> do
+        -- acquire
+        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
+          runInteractiveProcess pgm real_args mb_cwd mb_env
+        let cleanup_handles = do
+              hClose hStdIn
+              hClose hStdOut
+              hClose hStdErr
+        r <- try $ restore $ do
+          hSetBuffering hStdOut LineBuffering
+          hSetBuffering hStdErr LineBuffering
+          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
+          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
+            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
+            inner hProcess
+        case r of
+          -- onException
+          Left (SomeException e) -> do
+            terminateProcess hProcess
+            cleanup_handles
+            throw e
+          -- cleanup when there was no exception
+          Right s -> do
+            cleanup_handles
+            return s
+  safely $ \h -> do
+    -- we don't want to finish until 2 streams have been complete
+    -- (stdout and stderr)
+    log_loop chan (2 :: Integer)
+    -- after that, we wait for the process to finish and return the exit code.
+    waitForProcess h
+  where
+    -- t starts at the number of streams we're listening to (2) decrements each
+    -- time a reader process sends EOF. We are safe from looping forever if a
+    -- reader thread dies, because they send EOF in a finally handler.
+    log_loop _ 0 = return ()
+    log_loop chan t = do
+      msg <- readChan chan
+      case msg of
+        BuildMsg msg -> do
+          putLogMsg dflags NoReason SevInfo noSrcSpan
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        BuildError loc msg -> do
+          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        EOF ->
+          log_loop chan  (t-1)
+
+readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
+readerProc chan hdl filter_fn =
+    (do str <- hGetContents hdl
+        loop (linesPlatform (filter_fn str)) Nothing)
+    `finally`
+       writeChan chan EOF
+        -- ToDo: check errors more carefully
+        -- ToDo: in the future, the filter should be implemented as
+        -- a stream transformer.
+    where
+        loop []     Nothing    = return ()
+        loop []     (Just err) = writeChan chan err
+        loop (l:ls) in_err     =
+                case in_err of
+                  Just err@(BuildError srcLoc msg)
+                    | leading_whitespace l -> do
+                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
+                    | otherwise -> do
+                        writeChan chan err
+                        checkError l ls
+                  Nothing -> do
+                        checkError l ls
+                  _ -> panic "readerProc/loop"
+
+        checkError l ls
+           = case parseError l of
+                Nothing -> do
+                    writeChan chan (BuildMsg (text l))
+                    loop ls Nothing
+                Just (file, lineNum, colNum, msg) -> do
+                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
+                    loop ls (Just (BuildError srcLoc (text msg)))
+
+        leading_whitespace []    = False
+        leading_whitespace (x:_) = isSpace x
+
+parseError :: String -> Maybe (String, Int, Int, String)
+parseError s0 = case breakColon s0 of
+                Just (filename, s1) ->
+                    case breakIntColon s1 of
+                    Just (lineNum, s2) ->
+                        case breakIntColon s2 of
+                        Just (columnNum, s3) ->
+                            Just (filename, lineNum, columnNum, s3)
+                        Nothing ->
+                            Just (filename, lineNum, 0, s2)
+                    Nothing -> Nothing
+                Nothing -> Nothing
+
+breakColon :: String -> Maybe (String, String)
+breakColon xs = case break (':' ==) xs of
+                    (ys, _:zs) -> Just (ys, zs)
+                    _ -> Nothing
+
+breakIntColon :: String -> Maybe (Int, String)
+breakIntColon xs = case break (':' ==) xs of
+                       (ys, _:zs)
+                        | not (null ys) && all isAscii ys && all isDigit ys ->
+                           Just (read ys, zs)
+                       _ -> Nothing
+
+data BuildMessage
+  = BuildMsg   !SDoc
+  | BuildError !SrcLoc !SDoc
+  | EOF
+
+-- Divvy up text stream into lines, taking platform dependent
+-- line termination into account.
+linesPlatform :: String -> [String]
+#if !defined(mingw32_HOST_OS)
+linesPlatform ls = lines ls
+#else
+linesPlatform "" = []
+linesPlatform xs =
+  case lineBreak xs of
+    (as,xs1) -> as : linesPlatform xs1
+  where
+   lineBreak "" = ("","")
+   lineBreak ('\r':'\n':xs) = ([],xs)
+   lineBreak ('\n':xs) = ([],xs)
+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
+
+#endif
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
new file mode 100644
index 0000000000..66cc1ec1b2
--- /dev/null
+++ b/compiler/main/SysTools/Tasks.hs
@@ -0,0 +1,345 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Tasks running external programs for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Tasks where
+
+import Exception
+import ErrUtils
+import DynFlags
+import Outputable
+import Platform
+import Util
+
+import Data.Char
+import Data.List
+
+import System.IO
+import System.Process
+import GhcPrelude
+
+import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
+
+import SysTools.Process
+import SysTools.Info
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Running an external program}
+*                                                                      *
+************************************************************************
+-}
+
+runUnlit :: DynFlags -> [Option] -> IO ()
+runUnlit dflags args = do
+  let prog = pgm_L dflags
+      opts = getOpts dflags opt_L
+  runSomething dflags "Literate pre-processor" prog
+               (map Option opts ++ args)
+
+runCpp :: DynFlags -> [Option] -> IO ()
+runCpp dflags args =   do
+  let (p,args0) = pgm_P dflags
+      args1 = map Option (getOpts dflags opt_P)
+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id  "C pre-processor" p
+                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
+
+runPp :: DynFlags -> [Option] -> IO ()
+runPp dflags args =   do
+  let prog = pgm_F dflags
+      opts = map Option (getOpts dflags opt_F)
+  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
+
+runCc :: DynFlags -> [Option] -> IO ()
+runCc dflags args =   do
+  let (p,args0) = pgm_c dflags
+      args1 = map Option (getOpts dflags opt_c)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
+ where
+  -- discard some harmless warnings from gcc that we can't turn off
+  cc_filter = unlines . doFilter . lines
+
+  {-
+  gcc gives warnings in chunks like so:
+      In file included from /foo/bar/baz.h:11,
+                       from /foo/bar/baz2.h:22,
+                       from wibble.c:33:
+      /foo/flibble:14: global register variable ...
+      /foo/flibble:15: warning: call-clobbered r...
+  We break it up into its chunks, remove any call-clobbered register
+  warnings from each chunk, and then delete any chunks that we have
+  emptied of warnings.
+  -}
+  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
+  -- We can't assume that the output will start with an "In file inc..."
+  -- line, so we start off expecting a list of warnings rather than a
+  -- location stack.
+  chunkWarnings :: [String] -- The location stack to use for the next
+                            -- list of warnings
+                -> [String] -- The remaining lines to look at
+                -> [([String], [String])]
+  chunkWarnings loc_stack [] = [(loc_stack, [])]
+  chunkWarnings loc_stack xs
+      = case break loc_stack_start xs of
+        (warnings, lss:xs') ->
+            case span loc_start_continuation xs' of
+            (lsc, xs'') ->
+                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
+        _ -> [(loc_stack, xs)]
+
+  filterWarnings :: [([String], [String])] -> [([String], [String])]
+  filterWarnings [] = []
+  -- If the warnings are already empty then we are probably doing
+  -- something wrong, so don't delete anything
+  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
+  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
+                                       [] -> filterWarnings zs
+                                       ys' -> (xs, ys') : filterWarnings zs
+
+  unChunkWarnings :: [([String], [String])] -> [String]
+  unChunkWarnings [] = []
+  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
+
+  loc_stack_start        s = "In file included from " `isPrefixOf` s
+  loc_start_continuation s = "                 from " `isPrefixOf` s
+  wantedWarning w
+   | "warning: call-clobbered register used" `isContainedIn` w = False
+   | otherwise = True
+
+isContainedIn :: String -> String -> Bool
+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
+
+-- | Run the linker with some arguments and return the output
+askLd :: DynFlags -> [Option] -> IO String
+askLd dflags args = do
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingWith dflags "gcc" p args2 $ \real_args ->
+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
+
+runSplit :: DynFlags -> [Option] -> IO ()
+runSplit dflags args = do
+  let (p,args0) = pgm_s dflags
+  runSomething dflags "Splitter" p (args0++args)
+
+runAs :: DynFlags -> [Option] -> IO ()
+runAs dflags args = do
+  let (p,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env
+
+-- | Run the LLVM Optimiser
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+  let (p,args0) = pgm_lo dflags
+      args1 = map Option (getOpts dflags opt_lo)
+      -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
+      -- user can override flags passed by GHC. See #14821.
+  runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)
+
+-- | Run the LLVM Compiler
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+  let (p,args0) = pgm_lc dflags
+      args1 = map Option (getOpts dflags opt_lc)
+  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
+
+-- | Run the clang compiler (used as an assembler for the LLVM
+-- backend on OS X as LLVM doesn't support the OS X system
+-- assembler)
+runClang :: DynFlags -> [Option] -> IO ()
+runClang dflags args = do
+  let (clang,_) = pgm_lcc dflags
+      -- be careful what options we call clang with
+      -- see #5903 and #7617 for bugs caused by this.
+      (_,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  Exception.catch (do
+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
+    )
+    (\(err :: SomeException) -> do
+        errorMsg dflags $
+            text ("Error running clang! you need clang installed to use the" ++
+                  " LLVM backend") $+$
+            text "(or GHC tried to execute clang incorrectly)"
+        throwIO err
+    )
+
+-- | Figure out which version of LLVM we are running this session
+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
+figureLlvmVersion dflags = do
+  let (pgm,opts) = pgm_lc dflags
+      args = filter notNull (map showOpt opts)
+      -- we grab the args even though they should be useless just in
+      -- case the user is using a customised 'llc' that requires some
+      -- of the options they've specified. llc doesn't care what other
+      -- options are specified when '-version' is used.
+      args' = args ++ ["-version"]
+  ver <- catchIO (do
+              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
+                                              Nothing Nothing
+              {- > llc -version
+                  LLVM (http://llvm.org/):
+                    LLVM version 3.5.2
+                    ...
+              -}
+              hSetBinaryMode pout False
+              _     <- hGetLine pout
+              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
+              v     <- case span (/= '.') vline of
+                        ("",_)  -> fail "no digits!"
+                        (x,y) -> return (read x
+                                        , read $ takeWhile isDigit $ drop 1 y)
+
+              hClose pin
+              hClose pout
+              hClose perr
+              return $ Just v
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out LLVM version):" <+>
+                      text (show err))
+                errorMsg dflags $ vcat
+                    [ text "Warning:", nest 9 $
+                          text "Couldn't figure out LLVM version!" $$
+                          text ("Make sure you have installed LLVM " ++
+                                llvmVersionStr supportedLlvmVersion) ]
+                return Nothing)
+  return ver
+
+
+runLink :: DynFlags -> [Option] -> IO ()
+runLink dflags args = do
+  -- See Note [Run-time linker info]
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ linkargs ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
+  where
+    ld_filter = case (platformOS (targetPlatform dflags)) of
+                  OSSolaris2 -> sunos_ld_filter
+                  _ -> id
+{-
+  SunOS/Solaris ld emits harmless warning messages about unresolved
+  symbols in case of compiling into shared library when we do not
+  link against all the required libs. That is the case of GHC which
+  does not link against RTS library explicitly in order to be able to
+  choose the library later based on binary application linking
+  parameters. The warnings look like:
+
+Undefined                       first referenced
+  symbol                             in file
+stg_ap_n_fast                       ./T2386_Lib.o
+stg_upd_frame_info                  ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
+newCAF                              ./T2386_Lib.o
+stg_bh_upd_frame_info               ./T2386_Lib.o
+stg_ap_ppp_fast                     ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
+stg_ap_p_fast                       ./T2386_Lib.o
+stg_ap_pp_fast                      ./T2386_Lib.o
+ld: warning: symbol referencing errors
+
+  this is actually coming from T2386 testcase. The emitting of those
+  warnings is also a reason why so many TH testcases fail on Solaris.
+
+  Following filter code is SunOS/Solaris linker specific and should
+  filter out only linker warnings. Please note that the logic is a
+  little bit more complex due to the simple reason that we need to preserve
+  any other linker emitted messages. If there are any. Simply speaking
+  if we see "Undefined" and later "ld: warning:..." then we omit all
+  text between (including) the marks. Otherwise we copy the whole output.
+-}
+    sunos_ld_filter :: String -> String
+    sunos_ld_filter = unlines . sunos_ld_filter' . lines
+    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+                          then (ld_prefix x) ++ (ld_postfix x)
+                          else x
+    breakStartsWith x y = break (isPrefixOf x) y
+    ld_prefix = fst . breakStartsWith "Undefined"
+    undefined_found = not . null . snd . breakStartsWith "Undefined"
+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
+    ld_postfix = tail . snd . ld_warn_break
+    ld_warning_found = not . null . snd . ld_warn_break
+
+
+runLibtool :: DynFlags -> [Option] -> IO ()
+runLibtool dflags args = do
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let args1      = map Option (getOpts dflags opt_l)
+      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
+      libtool    = pgm_libtool dflags
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env
+
+runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
+runAr dflags cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingFiltered dflags id "Ar" ar args cwd Nothing
+
+askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
+askAr dflags mb_cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingWith dflags "Ar" ar args $ \real_args ->
+    readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
+
+runRanlib :: DynFlags -> [Option] -> IO ()
+runRanlib dflags args = do
+  let ranlib = pgm_ranlib dflags
+  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
+
+runMkDLL :: DynFlags -> [Option] -> IO ()
+runMkDLL dflags args = do
+  let (p,args0) = pgm_dll dflags
+      args1 = args0 ++ args
+  mb_env <- getGccEnv (args0++args)
+  runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
+
+runWindres :: DynFlags -> [Option] -> IO ()
+runWindres dflags args = do
+  let (gcc, gcc_args) = pgm_c dflags
+      windres = pgm_windres dflags
+      opts = map Option (getOpts dflags opt_windres)
+      quote x = "\"" ++ x ++ "\""
+      args' = -- If windres.exe and gcc.exe are in a directory containing
+              -- spaces then windres fails to run gcc. We therefore need
+              -- to tell it what command to use...
+              Option ("--preprocessor=" ++
+                      unwords (map quote (gcc :
+                                          map showOpt gcc_args ++
+                                          map showOpt opts ++
+                                          ["-E", "-xc", "-DRC_INVOKED"])))
+              -- ...but if we do that then if windres calls popen then
+              -- it can't understand the quoting, so we have to use
+              -- --use-temp-file so that it interprets it correctly.
+              -- See #1828.
+            : Option "--use-temp-file"
+            : args
+  mb_env <- getGccEnv gcc_args
+  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
+
+touch :: DynFlags -> String -> String -> IO ()
+touch dflags purpose arg =
+  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs
index b3bf6e651d..b7f343a3a5 100644
--- a/compiler/main/SysTools/Terminal.hs
+++ b/compiler/main/SysTools/Terminal.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module SysTools.Terminal (stderrSupportsAnsiColors) where
+
+import GhcPrelude
+
 #if defined MIN_VERSION_terminfo
 import Control.Exception (catch)
 import Data.Maybe (fromMaybe)
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 4b9fbae599..4e93439588 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -12,6 +12,8 @@ module TidyPgm (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes
 import DynFlags
 import CoreSyn
@@ -59,7 +61,6 @@ import Maybes
 import UniqSupply
 import ErrUtils (Severity(..))
 import Outputable
-import UniqDFM
 import SrcLoc
 import qualified ErrUtils as Err
 
@@ -69,7 +70,7 @@ import Data.List        ( sortBy )
 import Data.IORef       ( atomicModifyIORef' )
 
 {-
-Constructing the TypeEnv, Instances, Rules, VectInfo from which the
+Constructing the TypeEnv, Instances, Rules from which the
 ModIface is constructed, and which goes on to subsequent modules in
 --make mode.
 
@@ -163,7 +164,6 @@ mkBootModDetailsTc hsc_env
                              , md_rules     = []
                              , md_anns      = []
                              , md_exports   = exports
-                             , md_vect_info = noVectInfo
                              , md_complete_sigs = []
                              })
         }
@@ -200,7 +200,7 @@ mkBootTypeEnv exports ids tcs fam_insts
 
 
 globaliseAndTidyId :: Id -> Id
--- Takes an LocalId with an External Name,
+-- Takes a LocalId with an External Name,
 -- makes it into a GlobalId
 --     * unchanged Name (might be Internal or External)
 --     * unchanged details
@@ -219,18 +219,22 @@ globaliseAndTidyId id
 
 Plan B: include pragmas, make interfaces
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Figure out which Ids are externally visible
+* Step 1: Figure out which Ids are externally visible
+          See Note [Choosing external Ids]
+
+* Step 2: Gather the externally visible rules, separately from
+          the top-level bindings.
+          See Note [Finding external rules]
 
-* Tidy the bindings, externalising appropriate Ids
+* Step 3: Tidy the bindings, externalising appropriate Ids
+          See Note [Tidy the top-level bindings]
 
 * Drop all Ids from the TypeEnv, and add all the External Ids from
   the bindings.  (This adds their IdInfo to the TypeEnv; and adds
   floated-out Ids that weren't even in the TypeEnv before.)
 
-Step 1: Figure out external Ids
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note [choosing external names]
-
+Note [Choosing external Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See also the section "Interface stability" in the
 RecompilationAvoidance commentary:
   http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
@@ -240,9 +244,8 @@ First we figure out which Ids are "external" Ids.  An
 unit.  These are
   a) the user exported ones
   b) the ones bound to static forms
-  c) ones mentioned in the unfoldings, workers,
-     rules of externally-visible ones ,
-     or vectorised versions of externally-visible ones
+  c) ones mentioned in the unfoldings, workers, or
+     rules of externally-visible ones
 
 While figuring out which Ids are external, we pick a "tidy" OccName
 for each one.  That is, we make its OccName distinct from the other
@@ -270,8 +273,8 @@ as the bindings themselves are deterministic (they sometimes aren't!),
 the order in which they are presented to the tidying phase does not
 affect the names we assign.
 
-Step 2: Tidy the program
-~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Tidy the top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Next we traverse the bindings top to bottom.  For each *top-level*
 binder
 
@@ -318,7 +321,6 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_binds     = binds
                               , mg_patsyns   = patsyns
                               , mg_rules     = imp_rules
-                              , mg_vect_info = vect_info
                               , mg_anns      = anns
                               , mg_complete_sigs = complete_sigs
                               , mg_deps      = deps
@@ -345,7 +347,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
         ; (unfold_env, tidy_occ_env)
               <- chooseExternalIds hsc_env mod omit_prags expose_all
-                                   binds implicit_binds imp_rules (vectInfoVar vect_info)
+                                   binds implicit_binds imp_rules
         ; let { (trimmed_binds, trimmed_rules)
                     = findExternalRules omit_prags binds imp_rules unfold_env }
 
@@ -367,8 +369,6 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                 -- and indeed it does, but if omit_prags is on, ext_rules is
                 -- empty
 
-              ; tidy_vect_info = tidyVectInfo tidy_env vect_info
-
                 -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
                 -- and then override the PatSyns in the type_env with the new tidy ones
                 -- This is really the only reason we keep mg_patsyns at all; otherwise
@@ -438,7 +438,6 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                    ModDetails { md_types     = tidy_type_env,
                                 md_rules     = tidy_rules,
                                 md_insts     = tidy_cls_insts,
-                                md_vect_info = tidy_vect_info,
                                 md_fam_insts = fam_insts,
                                 md_exports   = exports,
                                 md_anns      = anns,      -- are already tidy
@@ -451,7 +450,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
             -> TypeEnv -> TypeEnv
 
--- The competed type environment is gotten from
+-- The completed type environment is gotten from
 --      a) the types and classes defined here (plus implicit things)
 --      b) adding Ids with correct IdInfo, including unfoldings,
 --              gotten from the bindings
@@ -487,38 +486,6 @@ extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
 extendTypeEnvWithPatSyns tidy_patsyns type_env
   = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
 
-tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
-tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
-                                         , vectInfoParallelVars = parallelVars
-                                         })
-  = info { vectInfoVar          = tidy_vars
-         , vectInfoParallelVars = tidy_parallelVars
-         }
-  where
-      -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
-      -- inconsistent)
-    tidy_vars = mkDVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
-                          | (var, var_v) <- eltsUDFM vars
-                          , let tidy_var   = lookup_var var
-                                tidy_var_v = lookup_var var_v
-                          , isExternalId tidy_var   && isExportedId tidy_var
-                          , isExternalId tidy_var_v && isExportedId tidy_var_v
-                          , isDataConWorkId var || not (isImplicitId var)
-                          ]
-
-    tidy_parallelVars = mkDVarSet
-                          [ tidy_var
-                          | var <- dVarSetElems parallelVars
-                          , let tidy_var = lookup_var var
-                          , isExternalId tidy_var && isExportedId tidy_var
-                          ]
-
-    lookup_var var = lookupWithDefaultVarEnv var_env var var
-
-    -- We need to make sure that all names getting into the iface version of 'VectInfo' are
-    -- external; otherwise, 'MkIface' will bomb out.
-    isExternalId = isExternalName . idName
-
 {-
 Note [Don't attempt to trim data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -619,7 +586,7 @@ get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
 *                                                                      *
 ************************************************************************
 
-See Note [Choosing external names].
+See Note [Choosing external Ids].
 -}
 
 type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
@@ -635,23 +602,22 @@ chooseExternalIds :: HscEnv
                   -> [CoreBind]
                   -> [CoreBind]
                   -> [CoreRule]
-                  -> DVarEnv (Var, Var)
                   -> IO (UnfoldEnv, TidyOccEnv)
                   -- Step 1 from the notes above
 
-chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars
+chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
        ; tidy_internal internal_ids unfold_env1 occ_env1 }
  where
   nc_var = hsc_NC hsc_env
 
-  -- init_ext_ids is the intial list of Ids that should be
+  -- init_ext_ids is the initial list of Ids that should be
   -- externalised.  It serves as the starting point for finding a
   -- deterministic, tidy, renaming for all external Ids in this
   -- module.
   --
-  -- It is sorted, so that it has adeterministic order (i.e. it's the
+  -- It is sorted, so that it has a deterministic order (i.e. it's the
   -- same list every time this module is compiled), in contrast to the
   -- bindings, which are ordered non-deterministically.
   init_work_list = zip init_ext_ids init_ext_ids
@@ -659,13 +625,10 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
 
   -- An Id should be external if either (a) it is exported,
   -- (b) it appears in the RHS of a local rule for an imported Id, or
-  -- (c) it is the vectorised version of an imported Id.
   -- See Note [Which rules to expose]
   is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
-                 || id `elemVarSet` vect_var_vs
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
-  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
 
   binders          = map fst $ flattenBinds binds
   implicit_binders = bindersOfBinds implicit_binds
@@ -715,9 +678,6 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                 | omit_prags = ([], False)
                 | otherwise  = addExternal expose_all refined_id
 
-                -- add vectorised version if any exists
-          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupDVarEnv vect_vars idocc)
-
                 -- 'idocc' is an *occurrence*, but we need to see the
                 -- unfolding in the *definition*; so look up in binder_set
           refined_id = case lookupVarSet binder_set idocc of
@@ -728,7 +688,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
           referrer' | isExportedId refined_id = refined_id
                     | otherwise               = referrer
       --
-      search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env'
+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
 
   tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
                 -> IO (UnfoldEnv, TidyOccEnv)
@@ -778,7 +738,7 @@ a VarSet, which is in a non-deterministic order when converted to a
 list.  Hence, here we define a free-variable finder that returns
 the free variables in the order that they are encountered.
 
-See Note [Choosing external names]
+See Note [Choosing external Ids]
 -}
 
 bndrFvsInOrder :: Bool -> Id -> [Id]
@@ -1133,9 +1093,14 @@ tidyTopBinds :: HscEnv
 
 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+       mkNaturalId <- lookupMkNaturalName dflags hsc_env
        integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
-       let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
-           result      = tidy cvt_integer init_env binds
+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+       let cvt_literal nt i = case nt of
+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+             _             -> Nothing
+           result      = tidy cvt_literal init_env binds
        seqBinds (snd result) `seq` return result
        -- This seqBinds avoids a spike in space usage (see #13564)
   where
@@ -1144,34 +1109,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
     init_env = (init_occ_env, emptyVarEnv)
 
     tidy _           env []     = (env, [])
-    tidy cvt_integer env (b:bs)
-        = let (env1, b')  = tidyTopBind dflags this_mod
-                                        cvt_integer unfold_env env b
-              (env2, bs') = tidy cvt_integer env1 bs
+    tidy cvt_literal env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env
+                                        env b
+              (env2, bs') = tidy cvt_literal env1 bs
           in  (env2, b':bs')
 
 ------------------------
 tidyTopBind  :: DynFlags
              -> Module
-             -> (Integer -> CoreExpr)
+             -> (LitNumType -> Integer -> Maybe CoreExpr)
              -> UnfoldEnv
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs dflags this_mod (subst1, cvt_integer)
+    caf_info      = hasCafRefs dflags this_mod
+                               (subst1, cvt_literal)
                                (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
                                 (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
@@ -1190,7 +1156,7 @@ tidyTopBind dflags this_mod cvt_integer unfold_env
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
         | or [ mayHaveCafRefs (hasCafRefs dflags this_mod
-                                          (subst1, cvt_integer)
+                                          (subst1, cvt_literal)
                                           (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
@@ -1242,6 +1208,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
         `setCafInfo`        caf_info
         `setArityInfo`      arity
         `setStrictnessInfo` final_sig
+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
+                                                 -- in CoreTidy
 
   | otherwise           -- Externally-visible Ids get the whole lot
   = vanillaIdInfo
@@ -1278,7 +1246,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
     --------- Unfolding ------------
     unf_info = unfoldingInfo idinfo
     unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
-                | otherwise   = noUnfolding
+                | otherwise   = minimal_unfold_info
+    minimal_unfold_info = zapUnfolding unf_info
     unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
     is_bot = isBottomingSig final_sig
     -- NB: do *not* expose the worker if show_unfold is off,
@@ -1295,6 +1264,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
     -- for bottoming functions), but we might still have a worker/wrapper
     -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs
 
+
     --------- Arity ------------
     -- Usually the Id will have an accurate arity on it, because
     -- the simplifier has just run, but not always.
@@ -1332,25 +1302,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised
 after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
 So we have to *predict* the result here, which is revolting.
 
-In particular CorePrep expands Integer literals.  So in the prediction code
-here we resort to applying the same expansion (cvt_integer). Ugh!
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
 -}
 
-type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
   -- The env finds the Caf-ness of the Id
-  -- The Integer -> CoreExpr is the desugaring function for Integer literals
+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+  -- Integer and Natural literals
   -- See Note [Disgusting computation of CafRefs]
 
 hasCafRefs :: DynFlags -> Module
            -> CafRefEnv -> Arity -> CoreExpr
            -> CafInfo
-hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise               = NoCafRefs
  where
-  mentions_cafs   = cafRefsE p expr
+  mentions_cafs   = cafRefsE expr
   is_dynamic_name = isDllName dflags this_mod
-  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+                                         cvt_literal expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
@@ -1358,34 +1331,36 @@ hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
   -- CorePrep later on, and we don't want to duplicate that
   -- knowledge in rhsIsStatic below.
 
-cafRefsE :: CafRefEnv -> Expr a -> Bool
-cafRefsE p (Var id)            = cafRefsV p id
-cafRefsE p (Lit lit)           = cafRefsL p lit
-cafRefsE p (App f a)           = cafRefsE p f || cafRefsE p a
-cafRefsE p (Lam _ e)           = cafRefsE p e
-cafRefsE p (Let b e)           = cafRefsEs p (rhssOfBind b) || cafRefsE p e
-cafRefsE p (Case e _ _ alts)   = cafRefsE p e || cafRefsEs p (rhssOfAlts alts)
-cafRefsE p (Tick _n e)         = cafRefsE p e
-cafRefsE p (Cast e _co)        = cafRefsE p e
-cafRefsE _ (Type _)            = False
-cafRefsE _ (Coercion _)        = False
-
-cafRefsEs :: CafRefEnv -> [Expr a] -> Bool
-cafRefsEs _ []     = False
-cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es
-
-cafRefsL :: CafRefEnv -> Literal -> Bool
--- Don't forget that mk_integer id might have Caf refs!
--- We first need to convert the Integer into its final form, to
--- see whether mkInteger is used.
-cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)
-cafRefsL _                  _                = False
-
-cafRefsV :: CafRefEnv -> Id -> Bool
-cafRefsV (subst, _) id
-  | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
-  | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
-  | otherwise                         = False
+  cafRefsE :: Expr a -> Bool
+  cafRefsE (Var id)            = cafRefsV id
+  cafRefsE (Lit lit)           = cafRefsL lit
+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a
+  cafRefsE (Lam _ e)           = cafRefsE e
+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e
+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+  cafRefsE (Tick _n e)         = cafRefsE e
+  cafRefsE (Cast e _co)        = cafRefsE e
+  cafRefsE (Type _)            = False
+  cafRefsE (Coercion _)        = False
+
+  cafRefsEs :: [Expr a] -> Bool
+  cafRefsEs []     = False
+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+  cafRefsL :: Literal -> Bool
+  -- Don't forget that mk_integer id might have Caf refs!
+  -- We first need to convert the Integer into its final form, to
+  -- see whether mkInteger is used. Same for LitNatural.
+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+    Just e  -> cafRefsE e
+    Nothing -> False
+  cafRefsL _                = False
+
+  cafRefsV :: Id -> Bool
+  cafRefsV id
+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+    | otherwise                         = False
 
 
 {-
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 45d170e28d..79c3440ff6 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -25,6 +25,8 @@ module AsmCodeGen (
 #include "nativeGen/NCG.h"
 
 
+import GhcPrelude
+
 import qualified X86.CodeGen
 import qualified X86.Regs
 import qualified X86.Instr
@@ -363,7 +365,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
 
           -- build the global register conflict graph
           let graphGlobal
-                  = foldl Color.union Color.initGraph
+                  = foldl' Color.union Color.initGraph
                   $ [ Color.raGraph stat
                           | stat@Color.RegAllocStatsStart{} <- stats]
 
@@ -927,16 +929,18 @@ generateJumpTables ncgImpl xs = concatMap f xs
 
 shortcutBranches
         :: DynFlags
-    -> NcgImpl statics instr jumpDest
+        -> NcgImpl statics instr jumpDest
         -> [NatCmmDecl statics instr]
         -> [NatCmmDecl statics instr]
 
 shortcutBranches dflags ncgImpl tops
-  | optLevel dflags < 1 = tops    -- only with -O or higher
-  | otherwise           = map (apply_mapping ncgImpl mapping) tops'
+  | gopt Opt_AsmShortcutting dflags
+  = map (apply_mapping ncgImpl mapping) tops'
+  | otherwise
+  = tops
   where
     (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
-    mapping = foldr plusUFM emptyUFM mappings
+    mapping = plusUFMList mappings
 
 build_mapping :: NcgImpl statics instr jumpDest
               -> GenCmmDecl d (LabelMap t) (ListGraph instr)
@@ -953,7 +957,7 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
     -- shorted.
     -- Don't completely eliminate loops here -- that can leave a dangling jump!
     (_, shortcut_blocks, others) =
-        foldl split (setEmpty :: LabelSet, [], []) blocks
+        foldl' split (setEmpty :: LabelSet, [], []) blocks
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just jd <- canShortcut ncgImpl insn,
           Just dest <- getJumpDestBlockId ncgImpl jd,
@@ -970,7 +974,7 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
     has_info l = mapMember l info
 
     -- build a mapping from BlockId to JumpDest for shorting branches
-    mapping = foldl add emptyUFM shortcut_blocks
+    mapping = foldl' add emptyUFM shortcut_blocks
     add ufm (id,dest) = addToUFM ufm id dest
 
 apply_mapping :: NcgImpl statics instr jumpDest
@@ -1212,15 +1216,15 @@ cmmExprNative referenceKind expr = do
         -- to use the register table, so we replace these registers
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
-          | arch == ArchPPC && not (gopt Opt_PIC dflags)
+          | arch == ArchPPC && not (positionIndependent dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
-          | arch == ArchPPC && not (gopt Opt_PIC dflags)
+          | arch == ArchPPC && not (positionIndependent dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
         CmmReg (CmmGlobal GCFun)
-          | arch == ArchPPC && not (gopt Opt_PIC dflags)
+          | arch == ArchPPC && not (positionIndependent dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
 
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs
index c52fe10b13..399d646000 100644
--- a/compiler/nativeGen/CPrim.hs
+++ b/compiler/nativeGen/CPrim.hs
@@ -5,12 +5,16 @@ module CPrim
     , atomicRMWLabel
     , cmpxchgLabel
     , popCntLabel
+    , pdepLabel
+    , pextLabel
     , bSwapLabel
     , clzLabel
     , ctzLabel
     , word2FloatLabel
     ) where
 
+import GhcPrelude
+
 import CmmType
 import CmmMachOp
 import Outputable
@@ -24,6 +28,24 @@ popCntLabel w = "hs_popcnt" ++ pprWidth w
     pprWidth W64 = "64"
     pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)
 
+pdepLabel :: Width -> String
+pdepLabel w = "hs_pdep" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)
+
+pextLabel :: Width -> String
+pextLabel w = "hs_pext" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)
+
 bSwapLabel :: Width -> String
 bSwapLabel w = "hs_bswap" ++ pprWidth w
   where
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index afeac030fd..0e645a2a56 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -2,6 +2,8 @@ module Dwarf (
   dwarfGen
   ) where
 
+import GhcPrelude
+
 import CLabel
 import CmmExpr         ( GlobalReg(..) )
 import Config          ( cProjectName, cProjectVersion )
@@ -147,7 +149,7 @@ debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
 {-
 Note [Splitting DebugBlocks]
 
-DWARF requires that we break up the the nested DebugBlocks produced from
+DWARF requires that we break up the nested DebugBlocks produced from
 the C-- AST. For instance, we begin with tick trees containing nested procs.
 For example,
 
@@ -180,10 +182,17 @@ procToDwarf df prc
                          _otherwise -> showSDocDump df $ ppr $ dblLabel prc
                     , dwLabel    = dblCLabel prc
                     , dwParent   = fmap mkAsmTempDieLabel
-                                   $ mfilter (/= dblCLabel prc)
+                                   $ mfilter goodParent
                                    $ fmap dblCLabel (dblParent prc)
-                      -- Omit parent if it would be self-referential
                     }
+  where
+  goodParent a | a == dblCLabel prc = False
+               -- Omit parent if it would be self-referential
+  goodParent a | not (externallyVisibleCLabel a)
+               , debugLevel df < 2 = False
+               -- We strip block information when running -g0 or -g1, don't
+               -- refer to blocks in that case. Fixes #14894.
+  goodParent _ = True
 
 -- | Generate DWARF info for a block
 blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
index a8034ef295..db5395af35 100644
--- a/compiler/nativeGen/Dwarf/Constants.hs
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -3,6 +3,8 @@
 
 module Dwarf.Constants where
 
+import GhcPrelude
+
 import AsmUtils
 import FastString
 import Platform
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index 3c4501f613..25629448dd 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -22,6 +22,8 @@ module Dwarf.Types
   )
   where
 
+import GhcPrelude
+
 import Debug
 import CLabel
 import CmmExpr         ( GlobalReg(..) )
@@ -344,7 +346,7 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
         procEnd     = mkAsmTempEndLabel procLbl
         ifInfo str  = if hasInfo then text str else empty
                       -- see [Note: Info Offset]
-    in vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
+    in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
             , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
             , ppr fdeLabel <> colon
             , pprData4' (ppr frameLbl <> char '-' <>
@@ -413,6 +415,12 @@ pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
 -- Note that this will not prevent GDB from failing to look-up the
 -- correct function name for the frame, as that uses the symbol table,
 -- which we can not manipulate as easily.
+--
+-- There's a GDB patch to address this at [1]. At the moment of writing
+-- it's not merged, so I recommend building GDB with the patch if you
+-- care about unwinding. The hack above doesn't cover every case.
+--
+-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
 
 -- | Get DWARF register ID for a given GlobalReg
 dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
@@ -490,9 +498,11 @@ pprUnwindExpr spIsCFA expr
         pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
         pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
         pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
-    in text "\t.uleb128 1f-.-1" $$ -- DW_FORM_block length
+    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
+       -- computed as the difference of the following local labels 2: and 1:
+       text "1:" $$
        pprE expr $$
-       text "1:"
+       text "2:"
 
 -- | Generate code for re-setting the unwind information for a
 -- register to @undefined@
diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs
index 00811f1375..82ecbecc14 100644
--- a/compiler/nativeGen/Format.hs
+++ b/compiler/nativeGen/Format.hs
@@ -20,6 +20,8 @@ module Format (
 
 where
 
+import GhcPrelude
+
 import Cmm
 import Outputable
 
@@ -68,6 +70,7 @@ floatFormat width
  = case width of
         W32     -> FF32
         W64     -> FF64
+        W80     -> FF80
         other   -> pprPanic "Format.floatFormat" (ppr other)
 
 
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 515d4f3d85..0bd99fbee8 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -14,6 +14,8 @@ module Instruction (
 
 where
 
+import GhcPrelude
+
 import Reg
 
 import BlockId
@@ -189,14 +191,12 @@ class   Instruction instr where
 
         -- Subtract an amount from the C stack pointer
         mkStackAllocInstr
-                :: Platform  -- TODO: remove (needed by x86/x86_64
-                             -- because they share an Instr type)
+                :: Platform
                 -> Int
-                -> instr
+                -> [instr]
 
         -- Add an amount to the C stack pointer
         mkStackDeallocInstr
-                :: Platform  -- TODO: remove (needed by x86/x86_64
-                             -- because they share an Instr type)
+                :: Platform
                 -> Int
-                -> instr
+                -> [instr]
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 6af0df5b01..b9532e17b5 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -37,6 +37,8 @@ where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Reg
 import Format
 import TargetReg
@@ -44,7 +46,7 @@ import TargetReg
 import BlockId
 import Hoopl.Collections
 import Hoopl.Label
-import CLabel           ( CLabel, mkAsmTempLabel )
+import CLabel           ( CLabel )
 import Debug
 import FastString       ( FastString )
 import UniqFM
@@ -158,8 +160,7 @@ getBlockIdNat
 
 getNewLabelNat :: NatM CLabel
 getNewLabelNat
- = do   u <- getUniqueNat
-        return (mkAsmTempLabel u)
+ = blockLbl <$> getBlockIdNat
 
 
 getNewRegNat :: Format -> NatM Reg
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
index bef0a21235..2f300c4614 100644
--- a/compiler/nativeGen/PIC.hs
+++ b/compiler/nativeGen/PIC.hs
@@ -47,6 +47,8 @@ module PIC (
 
 where
 
+import GhcPrelude
+
 import qualified PPC.Instr      as PPC
 import qualified PPC.Regs       as PPC
 
@@ -162,7 +164,7 @@ cmmMakePicReference dflags lbl
         | OSAIX <- platformOS $ targetPlatform dflags
         = CmmMachOp (MO_Add W32)
                 [ CmmReg (CmmGlobal PicBaseReg)
-                , CmmLit $ picRelative
+                , CmmLit $ picRelative dflags
                                 (platformArch   $ targetPlatform dflags)
                                 (platformOS     $ targetPlatform dflags)
                                 lbl ]
@@ -171,15 +173,16 @@ cmmMakePicReference dflags lbl
         | ArchPPC_64 _ <- platformArch $ targetPlatform dflags
         = CmmMachOp (MO_Add W32) -- code model medium
                 [ CmmReg (CmmGlobal PicBaseReg)
-                , CmmLit $ picRelative
+                , CmmLit $ picRelative dflags
                                 (platformArch   $ targetPlatform dflags)
                                 (platformOS     $ targetPlatform dflags)
                                 lbl ]
 
-        | (gopt Opt_PIC dflags || WayDyn `elem` ways dflags) && absoluteLabel lbl
+        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)
+            && absoluteLabel lbl
         = CmmMachOp (MO_Add (wordWidth dflags))
                 [ CmmReg (CmmGlobal PicBaseReg)
-                , CmmLit $ picRelative
+                , CmmLit $ picRelative dflags
                                 (platformArch   $ targetPlatform dflags)
                                 (platformOS     $ targetPlatform dflags)
                                 lbl ]
@@ -236,7 +239,7 @@ howToAccessLabel
 howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
 
         -- Assume all symbols will be in the same PE, so just access them directly.
-        | WayDyn `notElem` ways dflags
+        | not (gopt Opt_ExternalDynamicRefs dflags)
         = AccessDirectly
 
         -- If the target symbol is in another PE we need to access it via the
@@ -272,7 +275,7 @@ howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
         -- we'd need to pass the current Module all the way in to
         -- this function.
         | arch /= ArchX86_64
-        , gopt Opt_PIC dflags && externallyVisibleCLabel lbl
+        , positionIndependent dflags && externallyVisibleCLabel lbl
         = AccessViaSymbolPtr
 
         | otherwise
@@ -313,8 +316,8 @@ howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl
 --
 -- ELF tries to pretend to the main application code that dynamic linking does
 -- not exist. While this may sound convenient, it tends to mess things up in
--- very bad ways, so we have to be careful when we generate code for the main
--- program (-dynamic but no -fPIC).
+-- very bad ways, so we have to be careful when we generate code for a non-PIE
+-- main program (-dynamic but no -fPIC).
 --
 -- Indirect access is required for references to imported symbols
 -- from position independent code. It is also required from the main program
@@ -337,7 +340,8 @@ howToAccessLabel dflags _ os _ _ _
         --           if we don't dynamically link to Haskell code,
         --           it actually manages to do so without messing things up.
         | osElfTarget os
-        , not (gopt Opt_PIC dflags) && WayDyn `notElem` ways dflags
+        , not (positionIndependent dflags) &&
+          not (gopt Opt_ExternalDynamicRefs dflags)
         = AccessDirectly
 
 howToAccessLabel dflags arch os this_mod DataReference lbl
@@ -351,7 +355,7 @@ howToAccessLabel dflags arch os this_mod DataReference lbl
             -- via a symbol pointer (see below for an explanation why
             -- PowerPC32 Linux is especially broken).
             | arch == ArchPPC
-            , gopt Opt_PIC dflags
+            , positionIndependent dflags
             -> AccessViaSymbolPtr
 
             | otherwise
@@ -372,12 +376,13 @@ howToAccessLabel dflags arch os this_mod DataReference lbl
 
 howToAccessLabel dflags arch os this_mod CallReference lbl
         | osElfTarget os
-        , labelDynamic dflags this_mod lbl && not (gopt Opt_PIC dflags)
+        , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)
         = AccessDirectly
 
         | osElfTarget os
         , arch /= ArchX86
-        , labelDynamic dflags this_mod lbl && gopt Opt_PIC dflags
+        , labelDynamic dflags this_mod lbl
+        , positionIndependent dflags
         = AccessViaStub
 
 howToAccessLabel dflags _ os this_mod _ lbl
@@ -388,7 +393,7 @@ howToAccessLabel dflags _ os this_mod _ lbl
 
 -- all other platforms
 howToAccessLabel dflags _ _ _ _ _
-        | not (gopt Opt_PIC dflags)
+        | not (positionIndependent dflags)
         = AccessDirectly
 
         | otherwise
@@ -397,10 +402,10 @@ howToAccessLabel dflags _ _ _ _ _
 
 
 -- -------------------------------------------------------------------
--- | Says what we we have to add to our 'PIC base register' in order to
+-- | Says what we have to add to our 'PIC base register' in order to
 --      get the address of a label.
 
-picRelative :: Arch -> OS -> CLabel -> CmmLit
+picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit
 
 -- Darwin, but not x86_64:
 -- The PIC base register points to the PIC base label at the beginning
@@ -409,15 +414,15 @@ picRelative :: Arch -> OS -> CLabel -> CmmLit
 -- We have already made sure that all labels that are not from the current
 -- module are accessed indirectly ('as' can't calculate differences between
 -- undefined labels).
-picRelative arch OSDarwin lbl
+picRelative dflags arch OSDarwin lbl
         | arch /= ArchX86_64
-        = CmmLabelDiffOff lbl mkPicBaseLabel 0
+        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)
 
 -- On AIX we use an indirect local TOC anchored by 'gotLabel'.
 -- This way we use up only one global TOC entry per compilation-unit
 -- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)
-picRelative _ OSAIX lbl
-        = CmmLabelDiffOff lbl gotLabel 0
+picRelative dflags _ OSAIX lbl
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
 
 -- PowerPC Linux:
 -- The PIC base register points to our fake GOT. Use a label difference
@@ -425,9 +430,9 @@ picRelative _ OSAIX lbl
 -- We have made sure that *everything* is accessed indirectly, so this
 -- is only used for offsets from the GOT to symbol pointers inside the
 -- GOT.
-picRelative ArchPPC os lbl
+picRelative dflags ArchPPC os lbl
         | osElfTarget os
-        = CmmLabelDiffOff lbl gotLabel 0
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
 
 
 -- Most Linux versions:
@@ -437,7 +442,7 @@ picRelative ArchPPC os lbl
 -- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
 -- and a GotSymbolOffset label for other things.
 -- For reasons of tradition, the symbol offset label is written as a plain label.
-picRelative arch os lbl
+picRelative _ arch os lbl
         | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)
         = let   result
                         | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
@@ -448,7 +453,7 @@ picRelative arch os lbl
 
           in    result
 
-picRelative _ _ _
+picRelative _ _ _ _
         = panic "PositionIndependentCode.picRelative undefined for this platform"
 
 
@@ -467,7 +472,7 @@ needImportedSymbols dflags arch os
         -- PowerPC Linux: -fPIC or -dynamic
         | osElfTarget os
         , arch  == ArchPPC
-        = gopt Opt_PIC dflags || WayDyn `elem` ways dflags
+        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags
 
         -- PowerPC 64 Linux: always
         | osElfTarget os
@@ -477,7 +482,8 @@ needImportedSymbols dflags arch os
         -- i386 (and others?): -dynamic but not -fPIC
         | osElfTarget os
         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
-        = WayDyn `elem` ways dflags && not (gopt Opt_PIC dflags)
+        = gopt Opt_ExternalDynamicRefs dflags &&
+          not (positionIndependent dflags)
 
         | otherwise
         = False
@@ -499,7 +505,7 @@ gotLabel
 -- However, for PIC on x86, we need a small helper function.
 pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc
 pprGotDeclaration dflags ArchX86 OSDarwin
-        | gopt Opt_PIC dflags
+        | positionIndependent dflags
         = vcat [
                 text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
                 text ".weak_definition ___i686.get_pc_thunk.ax",
@@ -540,7 +546,7 @@ pprGotDeclaration _ (ArchPPC_64 _) _
 pprGotDeclaration dflags arch os
         | osElfTarget os
         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
-        , not (gopt Opt_PIC dflags)
+        , not (positionIndependent dflags)
         = empty
 
         | osElfTarget os
@@ -565,7 +571,7 @@ pprGotDeclaration _ _ _
 pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
 pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS = OSDarwin }) importedLbl
         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-        = case gopt Opt_PIC dflags of
+        = case positionIndependent dflags of
            False ->
             vcat [
                 text ".symbol_stub",
@@ -619,7 +625,7 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS
 
 pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl
         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-        = case gopt Opt_PIC dflags of
+        = case positionIndependent dflags of
            False ->
             vcat [
                 text ".symbol_stub",
@@ -652,7 +658,7 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS
                     text "\tjmp dyld_stub_binding_helper"
             ]
           $+$ vcat [        text ".section __DATA, __la_sym_ptr"
-                    <> (if gopt Opt_PIC dflags then int 2 else int 3)
+                    <> (if positionIndependent dflags then int 2 else int 3)
                     <> text ",lazy_symbol_pointers",
                 text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),
                     text "\t.indirect_symbol" <+> pprCLabel platform lbl,
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 1e88a1d025..f246ec36f1 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -25,6 +25,8 @@ where
 #include "../includes/MachDeps.h"
 
 -- NCG stuff:
+import GhcPrelude
+
 import CodeGen.Platform
 import PPC.Instr
 import PPC.Cond
@@ -52,7 +54,6 @@ import Hoopl.Graph
 -- The rest:
 import OrdList
 import Outputable
-import Unique
 import DynFlags
 
 import Control.Monad    ( mapAndUnzipM, when )
@@ -90,13 +91,23 @@ cmmTopCodeGen (CmmProc info lab live graph) = do
       case picBaseMb of
            Just picBase -> initializePicBase_ppc arch os picBase tops
            Nothing -> return tops
-    ArchPPC_64 ELF_V1 -> return tops
+    ArchPPC_64 ELF_V1 -> fixup_entry tops
                       -- generating function descriptor is handled in
                       -- pretty printer
-    ArchPPC_64 ELF_V2 -> return tops
+    ArchPPC_64 ELF_V2 -> fixup_entry tops
                       -- generating function prologue is handled in
                       -- pretty printer
     _          -> panic "PPC.cmmTopCodeGen: unknown arch"
+    where
+      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = do
+        let BasicBlock bID insns = entry
+        bID' <- if lab == (blockLbl bID)
+                then newBlockId
+                else return bID
+        let b' = BasicBlock bID' insns
+        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
+      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
 
 cmmTopCodeGen (CmmData sec dat) = do
   return [CmmData sec dat]  -- no translation, we just use CmmStatic
@@ -161,8 +172,8 @@ stmtToInstrs stmt = do
        -> genCCall target result_regs args
 
     CmmBranch id          -> genBranch id
-    CmmCondBranch arg true false _ -> do
-      b1 <- genCondJump true arg
+    CmmCondBranch arg true false prediction -> do
+      b1 <- genCondJump true arg prediction
       b2 <- genBranch false
       return (b1 `appOL` b2)
     CmmSwitch arg ids -> do dflags <- getDynFlags
@@ -214,7 +225,7 @@ getRegisterReg platform (CmmGlobal mid)
 jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
 jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
 jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel (getUnique blockid)
+    where blockLabel = blockLbl blockid
 
 
 
@@ -371,6 +382,14 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
         mov_lo = MR rlo expr_reg
     return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
                          rlo
+
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
 iselExpr64 expr
    = pprPanic "iselExpr64(powerpc)" (pprExpr expr)
 
@@ -719,7 +738,7 @@ data Amode
         = Amode AddrMode InstrBlock
 
 {-
-Now, given a tree (the argument to an CmmLoad) that references memory,
+Now, given a tree (the argument to a CmmLoad) that references memory,
 produce a suitable addressing mode.
 
 A Rule of the Game (tm) for Amodes: use of the addr bit must
@@ -1070,11 +1089,12 @@ comparison to do.
 genCondJump
     :: BlockId      -- the branch target
     -> CmmExpr      -- the condition on which to branch
+    -> Maybe Bool
     -> NatM InstrBlock
 
-genCondJump id bool = do
+genCondJump id bool prediction = do
   CondCode _ cond code <- getCondCode bool
-  return (code `snocOL` BCC cond id)
+  return (code `snocOL` BCC cond id prediction)
 
 
 
@@ -1098,6 +1118,90 @@ genCCall (PrimTarget MO_Touch) _ _
 genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
  = return $ nilOL
 
+genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+      (instr, n_code) <- case amop of
+            AMO_Add  -> getSomeRegOrImm ADD True reg_dst
+            AMO_Sub  -> case n of
+                CmmLit (CmmInt i _)
+                  | Just imm <- makeImmediate width True (-i)
+                   -> return (ADD reg_dst reg_dst (RIImm imm), nilOL)
+                _
+                   -> do
+                         (n_reg, n_code) <- getSomeReg n
+                         return  (SUBF reg_dst n_reg reg_dst, n_code)
+            AMO_And  -> getSomeRegOrImm AND False reg_dst
+            AMO_Nand -> do (n_reg, n_code) <- getSomeReg n
+                           return (NAND reg_dst reg_dst n_reg, n_code)
+            AMO_Or   -> getSomeRegOrImm OR False reg_dst
+            AMO_Xor  -> getSomeRegOrImm XOR False reg_dst
+      Amode addr_reg addr_code <- getAmodeIndex addr
+      lbl_retry <- getBlockIdNat
+      return $ n_code `appOL` addr_code
+        `appOL` toOL [ HWSYNC
+                     , BCC ALWAYS lbl_retry Nothing
+
+                     , NEWBLOCK lbl_retry
+                     , LDR fmt reg_dst addr_reg
+                     , instr
+                     , STC fmt reg_dst addr_reg
+                     , BCC NE lbl_retry (Just False)
+                     , ISYNC
+                     ]
+         where
+           getAmodeIndex (CmmMachOp (MO_Add _) [x, y])
+             = do
+                 (regX, codeX) <- getSomeReg x
+                 (regY, codeY) <- getSomeReg y
+                 return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+           getAmodeIndex other
+             = do
+                 (reg, code) <- getSomeReg other
+                 return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here!
+           getSomeRegOrImm op sign dst
+             = case n of
+                 CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i
+                    -> return (op dst dst (RIImm imm), nilOL)
+                 _
+                    -> do
+                          (n_reg, n_code) <- getSomeReg n
+                          return  (op dst dst (RIReg n_reg), n_code)
+
+genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+          form     = if widthInBits width == 64 then DS else D
+      Amode addr_reg addr_code <- getAmode form addr
+      lbl_end <- getBlockIdNat
+      return $ addr_code `appOL` toOL [ HWSYNC
+                                      , LD fmt reg_dst addr_reg
+                                      , CMP fmt reg_dst (RIReg reg_dst)
+                                      , BCC NE lbl_end (Just False)
+                                      , BCC ALWAYS lbl_end Nothing
+                            -- See Note [Seemingly useless cmp and bne]
+                                      , NEWBLOCK lbl_end
+                                      , ISYNC
+                                      ]
+
+-- Note [Seemingly useless cmp and bne]
+-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction
+-- the second paragraph says that isync may complete before storage accesses
+-- "associated" with a preceding instruction have been performed. The cmp
+-- operation and the following bne introduce a data and control dependency
+-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe
+-- Fetch).
+-- This is also what gcc does.
+
+
+genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
+    code <- assignMem_IntCode (intFormat width) addr val
+    return $ unitOL(HWSYNC) `appOL` code
+
 genCCall (PrimTarget (MO_Clz width)) [dst] [src]
  = do dflags <- getDynFlags
       let platform = targetPlatform dflags
@@ -1110,17 +1214,17 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src]
           lbl3 <- getBlockIdNat
           let vr_hi = getHiVRegFromLo vr_lo
               cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
-                           , BCC NE lbl2
-                           , BCC ALWAYS lbl1
+                           , BCC NE lbl2 Nothing
+                           , BCC ALWAYS lbl1 Nothing
 
                            , NEWBLOCK lbl1
                            , CNTLZ II32 reg_dst vr_lo
                            , ADD reg_dst reg_dst (RIImm (ImmInt 32))
-                           , BCC ALWAYS lbl3
+                           , BCC ALWAYS lbl3 Nothing
 
                            , NEWBLOCK lbl2
                            , CNTLZ II32 reg_dst vr_hi
-                           , BCC ALWAYS lbl3
+                           , BCC ALWAYS lbl3 Nothing
 
                            , NEWBLOCK lbl3
                            ]
@@ -1167,8 +1271,8 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
           cnttzlo <- cnttz format reg_dst vr_lo
           let vr_hi = getHiVRegFromLo vr_lo
               cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
-                             , BCC NE lbl2
-                             , BCC ALWAYS lbl1
+                             , BCC NE lbl2 Nothing
+                             , BCC ALWAYS lbl1 Nothing
 
                              , NEWBLOCK lbl1
                              , ADD x' vr_hi (RIImm (ImmInt (-1)))
@@ -1176,12 +1280,12 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
                              , CNTLZ format r' x''
                                -- 32 + (32 - clz(x''))
                              , SUBFC reg_dst r' (RIImm (ImmInt 64))
-                             , BCC ALWAYS lbl3
+                             , BCC ALWAYS lbl3 Nothing
 
                              , NEWBLOCK lbl2
                              ]
                         `appOL` cnttzlo `appOL`
-                        toOL [ BCC ALWAYS lbl3
+                        toOL [ BCC ALWAYS lbl3 Nothing
 
                              , NEWBLOCK lbl3
                              ]
@@ -1229,6 +1333,7 @@ genCCall target dest_regs argsAndHints
         PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs
                                                 argsAndHints
         PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints
+        PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints
         PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints
         PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width
                                                    dest_regs argsAndHints
@@ -1315,21 +1420,21 @@ genCCall target dest_regs argsAndHints
                                      -- rhat = un32 - q1*vn1
                                    , MULL fmt tmp q1 (RIReg vn1)
                                    , SUBF rhat tmp un32
-                                   , BCC ALWAYS again1
+                                   , BCC ALWAYS again1 Nothing
 
                                    , NEWBLOCK again1
                                      -- if (q1 >= b || q1*vn0 > b*rhat + un1)
                                    , CMPL fmt q1 (RIReg b)
-                                   , BCC GEU then1
-                                   , BCC ALWAYS no1
+                                   , BCC GEU then1 Nothing
+                                   , BCC ALWAYS no1 Nothing
 
                                    , NEWBLOCK no1
                                    , MULL fmt tmp q1 (RIReg vn0)
                                    , SL fmt tmp1 rhat (RIImm (ImmInt half))
                                    , ADD tmp1 tmp1 (RIReg un1)
                                    , CMPL fmt tmp (RIReg tmp1)
-                                   , BCC LEU endif1
-                                   , BCC ALWAYS then1
+                                   , BCC LEU endif1 Nothing
+                                   , BCC ALWAYS then1 Nothing
 
                                    , NEWBLOCK then1
                                      -- q1 = q1 - 1
@@ -1338,8 +1443,8 @@ genCCall target dest_regs argsAndHints
                                    , ADD rhat rhat (RIReg vn1)
                                      -- if (rhat < b) goto again1
                                    , CMPL fmt rhat (RIReg b)
-                                   , BCC LTT again1
-                                   , BCC ALWAYS endif1
+                                   , BCC LTT again1 Nothing
+                                   , BCC ALWAYS endif1 Nothing
 
                                    , NEWBLOCK endif1
                                      -- un21 = un32*b + un1 - q1*v
@@ -1353,21 +1458,21 @@ genCCall target dest_regs argsAndHints
                                      -- rhat = un21- q0*vn1
                                    , MULL fmt tmp q0 (RIReg vn1)
                                    , SUBF rhat tmp un21
-                                   , BCC ALWAYS again2
+                                   , BCC ALWAYS again2 Nothing
 
                                    , NEWBLOCK again2
                                      -- if (q0>b || q0*vn0 > b*rhat + un0)
                                    , CMPL fmt q0 (RIReg b)
-                                   , BCC GEU then2
-                                   , BCC ALWAYS no2
+                                   , BCC GEU then2 Nothing
+                                   , BCC ALWAYS no2 Nothing
 
                                    , NEWBLOCK no2
                                    , MULL fmt tmp q0 (RIReg vn0)
                                    , SL fmt tmp1 rhat (RIImm (ImmInt half))
                                    , ADD tmp1 tmp1 (RIReg un0)
                                    , CMPL fmt tmp (RIReg tmp1)
-                                   , BCC LEU endif2
-                                   , BCC ALWAYS then2
+                                   , BCC LEU endif2 Nothing
+                                   , BCC ALWAYS then2 Nothing
 
                                    , NEWBLOCK then2
                                      -- q0 = q0 - 1
@@ -1376,8 +1481,8 @@ genCCall target dest_regs argsAndHints
                                    , ADD rhat rhat (RIReg vn1)
                                      -- if (rhat<b) goto again2
                                    , CMPL fmt rhat (RIReg b)
-                                   , BCC LTT again2
-                                   , BCC ALWAYS endif2
+                                   , BCC LTT again2 Nothing
+                                   , BCC ALWAYS endif2 Nothing
 
                                    , NEWBLOCK endif2
                                      -- compute remainder
@@ -1419,6 +1524,11 @@ genCCall target dest_regs argsAndHints
               add2Op _ _ _
                 = panic "genCCall: Wrong number of arguments/results for add2"
 
+              addcOp platform [res_r, res_c] [arg_x, arg_y]
+                = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]
+              addcOp _ _ _
+                = panic "genCCall: Wrong number of arguments/results for addc"
+
               -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,
               -- which is 0 for borrow and 1 otherwise. We need 1 and 0
               -- so xor with 1.
@@ -1598,7 +1708,7 @@ genCCall' dflags gcp target dest_regs args
         uses_pic_base_implicitly = do
             -- See Note [implicit register in PPC PIC code]
             -- on why we claim to use PIC register here
-            when (gopt Opt_PIC dflags && target32Bit platform) $ do
+            when (positionIndependent dflags && target32Bit platform) $ do
                 _ <- getPicBaseNat $ archWordFormat True
                 return ()
 
@@ -1881,6 +1991,10 @@ genCCall' dflags gcp target dest_regs args
                     MO_F32_Tanh  -> (fsLit "tanh", True)
                     MO_F32_Pwr   -> (fsLit "pow", True)
 
+                    MO_F32_Asinh -> (fsLit "asinh", True)
+                    MO_F32_Acosh -> (fsLit "acosh", True)
+                    MO_F32_Atanh -> (fsLit "atanh", True)
+
                     MO_F64_Exp   -> (fsLit "exp", False)
                     MO_F64_Log   -> (fsLit "log", False)
                     MO_F64_Sqrt  -> (fsLit "sqrt", False)
@@ -1899,32 +2013,40 @@ genCCall' dflags gcp target dest_regs args
                     MO_F64_Tanh  -> (fsLit "tanh", False)
                     MO_F64_Pwr   -> (fsLit "pow", False)
 
+                    MO_F64_Asinh -> (fsLit "asinh", False)
+                    MO_F64_Acosh -> (fsLit "acosh", False)
+                    MO_F64_Atanh -> (fsLit "atanh", False)
+
                     MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
 
                     MO_Memcpy _  -> (fsLit "memcpy", False)
                     MO_Memset _  -> (fsLit "memset", False)
                     MO_Memmove _ -> (fsLit "memmove", False)
+                    MO_Memcmp _  -> (fsLit "memcmp", False)
 
                     MO_BSwap w   -> (fsLit $ bSwapLabel w, False)
                     MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
-                    MO_Clz w     -> (fsLit $ clzLabel w, False)
-                    MO_Ctz w     -> (fsLit $ ctzLabel w, False)
-                    MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False)
+                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)
+                    MO_Pext w    -> (fsLit $ pextLabel w, False)
+                    MO_Clz _     -> unsupported
+                    MO_Ctz _     -> unsupported
+                    MO_AtomicRMW {} -> unsupported
                     MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
-                    MO_AtomicRead w  -> (fsLit $ atomicReadLabel w, False)
-                    MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False)
+                    MO_AtomicRead _  -> unsupported
+                    MO_AtomicWrite _ -> unsupported
 
                     MO_S_QuotRem {}  -> unsupported
                     MO_U_QuotRem {}  -> unsupported
                     MO_U_QuotRem2 {} -> unsupported
                     MO_Add2 {}       -> unsupported
+                    MO_AddWordC {}   -> unsupported
                     MO_SubWordC {}   -> unsupported
                     MO_AddIntC {}    -> unsupported
                     MO_SubIntC {}    -> unsupported
                     MO_U_Mul2 {}     -> unsupported
                     MO_WriteBarrier  -> unsupported
                     MO_Touch         -> unsupported
-                    (MO_Prefetch_Data _ ) -> unsupported
+                    MO_Prefetch_Data _ -> unsupported
                 unsupported = panic ("outOfLineCmmOp: " ++ show mop
                                   ++ " not supported")
 
@@ -1950,7 +2072,7 @@ genSwitch dflags expr targets
                     ]
         return code
 
-  | (gopt Opt_PIC dflags) || (not $ target32Bit $ targetPlatform dflags)
+  | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)
   = do
         (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
         let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
@@ -1988,15 +2110,16 @@ generateJumpTableForInstr :: DynFlags -> Instr
                           -> Maybe (NatCmmDecl CmmStatics Instr)
 generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =
     let jumpTable
-            | (gopt Opt_PIC dflags)
+            | (positionIndependent dflags)
               || (not $ target32Bit $ targetPlatform dflags)
             = map jumpTableEntryRel ids
             | otherwise = map (jumpTableEntry dflags) ids
                 where jumpTableEntryRel Nothing
                         = CmmStaticLit (CmmInt 0 (wordWidth dflags))
                       jumpTableEntryRel (Just blockid)
-                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                            where blockLabel = mkAsmTempLabel (getUnique blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
+                                         (wordWidth dflags))
+                            where blockLabel = blockLbl blockid
     in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
 generateJumpTableForInstr _ _ = Nothing
 
diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs
index 0e4b1fd701..bd8bdee81a 100644
--- a/compiler/nativeGen/PPC/Cond.hs
+++ b/compiler/nativeGen/PPC/Cond.hs
@@ -8,6 +8,8 @@ module PPC.Cond (
 
 where
 
+import GhcPrelude
+
 import Panic
 
 data Cond
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index eb179c5a99..8eb5e8fa8d 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -23,6 +23,8 @@ module PPC.Instr (
 
 where
 
+import GhcPrelude
+
 import PPC.Regs
 import PPC.Cond
 import Instruction
@@ -75,19 +77,19 @@ instance Instruction Instr where
         mkStackDeallocInstr     = ppc_mkStackDeallocInstr
 
 
-ppc_mkStackAllocInstr :: Platform -> Int -> Instr
+ppc_mkStackAllocInstr :: Platform -> Int -> [Instr]
 ppc_mkStackAllocInstr platform amount
   = ppc_mkStackAllocInstr' platform (-amount)
 
-ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
+ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr]
 ppc_mkStackDeallocInstr platform amount
   = ppc_mkStackAllocInstr' platform amount
 
-ppc_mkStackAllocInstr' :: Platform -> Int -> Instr
+ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr]
 ppc_mkStackAllocInstr' platform amount
   = case platformArch platform of
-    ArchPPC      -> UPDATE_SP II32 (ImmInt amount)
-    ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount)
+    ArchPPC      -> [UPDATE_SP II32 (ImmInt amount)]
+    ArchPPC_64 _ -> [UPDATE_SP II64 (ImmInt amount)]
     _            -> panic $ "ppc_mkStackAllocInstr' "
                             ++ show (platformArch platform)
 
@@ -124,7 +126,7 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
 
         insert_stack_insns (BasicBlock id insns)
             | Just new_blockid <- mapLookup id new_blockmap
-                = [ BasicBlock id [alloc, BCC ALWAYS new_blockid]
+                = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing]
                   , BasicBlock new_blockid block'
                   ]
             | otherwise
@@ -137,11 +139,11 @@ allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
             -- "labeled-goto" we use JMP, and for "computed-goto" we
             -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
             = case insn of
-                JMP _           -> dealloc : insn : r
-                BCTR [] Nothing -> dealloc : insn : r
+                JMP _           -> dealloc ++ (insn : r)
+                BCTR [] Nothing -> dealloc ++ (insn : r)
                 BCTR ids label  -> BCTR (map (fmap retarget) ids) label : r
-                BCCFAR cond b   -> BCCFAR cond (retarget b) : r
-                BCC    cond b   -> BCC    cond (retarget b) : r
+                BCCFAR cond b p -> BCCFAR cond (retarget b) p : r
+                BCC    cond b p -> BCC    cond (retarget b) p : r
                 _               -> insn : r
             -- BL and BCTRL are call-like instructions rather than
             -- jumps, and are used only for C calls.
@@ -190,10 +192,12 @@ data Instr
     -- Loads and stores.
     | LD      Format Reg AddrMode   -- Load format, dst, src
     | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset
+    | LDR     Format Reg AddrMode   -- Load and reserve format, dst, src
     | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src
     | ST      Format Reg AddrMode   -- Store format, src, dst
     | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset
     | STU     Format Reg AddrMode   -- Store with Update format, src, dst
+    | STC     Format Reg AddrMode   -- Store conditional format, src, dst
     | LIS     Reg Imm               -- Load Immediate Shifted dst, src
     | LI      Reg Imm               -- Load Immediate dst, src
     | MR      Reg Reg               -- Move Register dst, src -- also for fmr
@@ -201,8 +205,12 @@ data Instr
     | CMP     Format Reg RI         -- format, src1, src2
     | CMPL    Format Reg RI         -- format, src1, src2
 
-    | BCC     Cond BlockId
-    | BCCFAR  Cond BlockId
+    | BCC     Cond BlockId (Maybe Bool) -- cond, block, hint
+    | BCCFAR  Cond BlockId (Maybe Bool) -- cond, block, hint
+                                    --   hint:
+                                    --    Just True:  branch likely taken
+                                    --    Just False: branch likely not taken
+                                    --    Nothing:    no hint
     | JMP     CLabel                -- same as branch,
                                     -- but with CLabel instead of block ID
     | MTCTR   Reg
@@ -232,6 +240,7 @@ data Instr
     | DIV     Format Bool Reg Reg Reg
     | AND     Reg Reg RI            -- dst, src1, src2
     | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2
+    | NAND    Reg Reg Reg           -- dst, src1, src2
     | OR      Reg Reg RI            -- dst, src1, src2
     | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2
     | XOR     Reg Reg RI            -- dst, src1, src2
@@ -272,6 +281,8 @@ data Instr
     | MFLR    Reg               -- move from link register
     | FETCHPC Reg               -- pseudo-instruction:
                                 -- bcl to next insn, mflr reg
+    | HWSYNC                    -- heavy weight sync
+    | ISYNC                     -- instruction synchronize
     | LWSYNC                    -- memory barrier
     | NOP                       -- no operation, PowerPC 64 bit
                                 -- needs this as place holder to
@@ -290,17 +301,19 @@ ppc_regUsageOfInstr platform instr
  = case instr of
     LD      _ reg addr       -> usage (regAddr addr, [reg])
     LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
+    LDR     _ reg addr       -> usage (regAddr addr, [reg])
     LA      _ reg addr       -> usage (regAddr addr, [reg])
     ST      _ reg addr       -> usage (reg : regAddr addr, [])
     STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
     STU     _ reg addr       -> usage (reg : regAddr addr, [])
+    STC     _ reg addr       -> usage (reg : regAddr addr, [])
     LIS     reg _            -> usage ([], [reg])
     LI      reg _            -> usage ([], [reg])
     MR      reg1 reg2        -> usage ([reg2], [reg1])
     CMP     _ reg ri         -> usage (reg : regRI ri,[])
     CMPL    _ reg ri         -> usage (reg : regRI ri,[])
-    BCC     _ _              -> noUsage
-    BCCFAR  _ _              -> noUsage
+    BCC     _ _ _            -> noUsage
+    BCCFAR  _ _ _            -> noUsage
     MTCTR   reg              -> usage ([reg],[])
     BCTR    _ _              -> noUsage
     BL      _ params         -> usage (params, callClobberedRegs platform)
@@ -325,6 +338,7 @@ ppc_regUsageOfInstr platform instr
 
     AND     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
     ANDC    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
+    NAND    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
     OR      reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
     ORIS    reg1 reg2 _     -> usage ([reg2], [reg1])
     XOR     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
@@ -380,17 +394,19 @@ ppc_patchRegsOfInstr instr env
  = case instr of
     LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)
     LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
+    LDR     fmt reg addr    -> LDR fmt (env reg) (fixAddr addr)
     LA      fmt reg addr    -> LA fmt (env reg) (fixAddr addr)
     ST      fmt reg addr    -> ST fmt (env reg) (fixAddr addr)
     STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
     STU     fmt reg addr    -> STU fmt (env reg) (fixAddr addr)
+    STC     fmt reg addr    -> STC fmt (env reg) (fixAddr addr)
     LIS     reg imm         -> LIS (env reg) imm
     LI      reg imm         -> LI (env reg) imm
     MR      reg1 reg2       -> MR (env reg1) (env reg2)
     CMP     fmt reg ri      -> CMP fmt (env reg) (fixRI ri)
     CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)
-    BCC     cond lbl        -> BCC cond lbl
-    BCCFAR  cond lbl        -> BCCFAR cond lbl
+    BCC     cond lbl p      -> BCC cond lbl p
+    BCCFAR  cond lbl p      -> BCCFAR cond lbl p
     MTCTR   reg             -> MTCTR (env reg)
     BCTR    targets lbl     -> BCTR targets lbl
     BL      imm argRegs     -> BL imm argRegs    -- argument regs
@@ -417,6 +433,7 @@ ppc_patchRegsOfInstr instr env
 
     AND     reg1 reg2 ri    -> AND (env reg1) (env reg2) (fixRI ri)
     ANDC    reg1 reg2 reg3  -> ANDC (env reg1) (env reg2) (env reg3)
+    NAND    reg1 reg2 reg3  -> NAND (env reg1) (env reg2) (env reg3)
     OR      reg1 reg2 ri    -> OR  (env reg1) (env reg2) (fixRI ri)
     ORIS    reg1 reg2 imm   -> ORIS (env reg1) (env reg2) imm
     XOR     reg1 reg2 ri    -> XOR (env reg1) (env reg2) (fixRI ri)
@@ -480,8 +497,8 @@ ppc_isJumpishInstr instr
 ppc_jumpDestsOfInstr :: Instr -> [BlockId]
 ppc_jumpDestsOfInstr insn
   = case insn of
-        BCC _ id        -> [id]
-        BCCFAR _ id     -> [id]
+        BCC _ id _      -> [id]
+        BCCFAR _ id _   -> [id]
         BCTR targets _  -> [id | Just id <- targets]
         _               -> []
 
@@ -492,8 +509,8 @@ ppc_jumpDestsOfInstr insn
 ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
 ppc_patchJumpInstr insn patchF
   = case insn of
-        BCC cc id       -> BCC cc (patchF id)
-        BCCFAR cc id    -> BCCFAR cc (patchF id)
+        BCC cc id p     -> BCC cc (patchF id) p
+        BCCFAR cc id p  -> BCCFAR cc (patchF id) p
         BCTR ids lbl    -> BCTR (map (fmap patchF) ids) lbl
         _               -> insn
 
@@ -631,16 +648,12 @@ ppc_mkRegRegMoveInstr src dst
 
 
 -- | Make an unconditional jump instruction.
--- For architectures with branch delay slots, its ok to put
--- a NOP after the jump. Don't fill the delay slot with an
--- instruction that references regs or you'll confuse the
--- linear allocator.
 ppc_mkJumpInstr
     :: BlockId
     -> [Instr]
 
 ppc_mkJumpInstr id
-    = [BCC ALWAYS id]
+    = [BCC ALWAYS id Nothing]
 
 
 -- | Take the source and destination from this reg -> reg move instruction
@@ -669,12 +682,12 @@ makeFarBranches info_env blocks
         handleBlock addr (BasicBlock id instrs)
                 = BasicBlock id (zipWith makeFar [addr..] instrs)
 
-        makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
-        makeFar addr (BCC cond tgt)
+        makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing
+        makeFar addr (BCC cond tgt p)
             | abs (addr - targetAddr) >= nearLimit
-            = BCCFAR cond tgt
+            = BCCFAR cond tgt p
             | otherwise
-            = BCC cond tgt
+            = BCC cond tgt p
             where Just targetAddr = lookupUFM blockAddressMap tgt
         makeFar _ other            = other
 
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 63d01c3913..2f64d82ee5 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -9,6 +9,8 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PPC.Ppr (pprNatCmmDecl) where
 
+import GhcPrelude
+
 import PPC.Regs
 import PPC.Instr
 import PPC.Cond
@@ -23,9 +25,10 @@ import Cmm hiding (topInfoTable)
 import Hoopl.Collections
 import Hoopl.Label
 
+import BlockId
 import CLabel
 
-import Unique                ( pprUniqueAlways, Uniquable(..) )
+import Unique                ( pprUniqueAlways, getUnique )
 import Platform
 import FastString
 import Outputable
@@ -78,19 +81,17 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
 
 pprFunctionDescriptor :: CLabel -> SDoc
 pprFunctionDescriptor lab = pprGloblDecl lab
-                        $$  text ".section \".opd\",\"aw\""
-                        $$  text ".align 3"
+                        $$  text "\t.section \".opd\", \"aw\""
+                        $$  text "\t.align 3"
                         $$  ppr lab <> char ':'
-                        $$  text ".quad ."
-                        <> ppr lab
-                        <> text ",.TOC.@tocbase,0"
-                        $$  text ".previous"
-                        $$  text ".type "
-                        <> ppr lab
-                        <> text ", @function"
-                        $$  char '.'
-                        <> ppr lab
-                        <> char ':'
+                        $$  text "\t.quad ."
+                        <>  ppr lab
+                        <>  text ",.TOC.@tocbase,0"
+                        $$  text "\t.previous"
+                        $$  text "\t.type"
+                        <+> ppr lab
+                        <>  text ", @function"
+                        $$  char '.' <> ppr lab <> char ':'
 
 pprFunctionPrologue :: CLabel ->SDoc
 pprFunctionPrologue lab =  pprGloblDecl lab
@@ -108,7 +109,7 @@ pprFunctionPrologue lab =  pprGloblDecl lab
 pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
 pprBasicBlock info_env (BasicBlock blockid instrs)
   = maybe_infotable $$
-    pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+    pprLabel (blockLbl blockid) $$
     vcat (map pprInstr instrs)
   where
     maybe_infotable = case mapLookup blockid info_env of
@@ -310,11 +311,13 @@ pprImm (HIGHESTA i)
 
 pprAddr :: AddrMode -> SDoc
 pprAddr (AddrRegReg r1 r2)
-  = pprReg r1 <+> text ", " <+> pprReg r2
-
-pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
-pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
-pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
+  = pprReg r1 <> char ',' <+> pprReg r2
+pprAddr (AddrRegImm r1 (ImmInt i))
+  = hcat [ int i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInteger i))
+  = hcat [ integer i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 imm)
+  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 
 
 pprSectionAlign :: Section -> SDoc
@@ -450,15 +453,27 @@ pprInstr (LD fmt reg addr) = hcat [
         text ", ",
         pprAddr addr
     ]
+
 pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
    sdocWithPlatform $ \platform -> vcat [
          pprInstr (ADDIS (tmpReg platform) source (HA off)),
          pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
     ]
-
 pprInstr (LDFAR _ _ _) =
    panic "PPC.Ppr.pprInstr LDFAR: no match"
 
+pprInstr (LDR fmt reg1 addr) = hcat [
+  text "\tl",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr LDR: no match",
+  text "arx\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
+
 pprInstr (LA fmt reg addr) = hcat [
         char '\t',
         text "l",
@@ -508,6 +523,17 @@ pprInstr (STU fmt reg addr) = hcat [
         text ", ",
         pprAddr addr
     ]
+pprInstr (STC fmt reg1 addr) = hcat [
+  text "\tst",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr STC: no match",
+  text "cx.\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
 pprInstr (LIS reg imm) = hcat [
         char '\t',
         text "lis",
@@ -569,19 +595,25 @@ pprInstr (CMPL fmt reg ri) = hcat [
                     RIReg _ -> empty
                     RIImm _ -> char 'i'
             ]
-pprInstr (BCC cond blockid) = hcat [
+pprInstr (BCC cond blockid prediction) = hcat [
         char '\t',
         text "b",
         pprCond cond,
+        pprPrediction prediction,
         char '\t',
         ppr lbl
     ]
-    where lbl = mkAsmTempLabel (getUnique blockid)
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          pprPrediction p = case p of
+            Nothing    -> empty
+            Just True  -> char '+'
+            Just False -> char '-'
 
-pprInstr (BCCFAR cond blockid) = vcat [
+pprInstr (BCCFAR cond blockid prediction) = vcat [
         hcat [
             text "\tb",
             pprCond (condNegate cond),
+            neg_prediction,
             text "\t$+8"
         ],
         hcat [
@@ -589,7 +621,11 @@ pprInstr (BCCFAR cond blockid) = vcat [
             ppr lbl
         ]
     ]
-    where lbl = mkAsmTempLabel (getUnique blockid)
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          neg_prediction = case prediction of
+            Nothing    -> empty
+            Just True  -> char '-'
+            Just False -> char '+'
 
 pprInstr (JMP lbl)
   -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
@@ -741,6 +777,7 @@ pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
     ]
 pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
 pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)
+pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)
 
 pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
 pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
@@ -922,6 +959,10 @@ pprInstr (FETCHPC reg) = vcat [
         hcat [ text "1:\tmflr\t", pprReg reg ]
     ]
 
+pprInstr HWSYNC = text "\tsync"
+
+pprInstr ISYNC  = text "\tisync"
+
 pprInstr LWSYNC = text "\tlwsync"
 
 pprInstr NOP = text "\tnop"
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index c4724d4193..30a07b9440 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -20,6 +20,8 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import PPC.Instr
 
 import BlockId
@@ -49,14 +51,14 @@ shortcutStatics fn (Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
   = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
-  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
         -- slightly dodgy, we're ignoring the second label, but this
         -- works with the way we use CmmLabelDiffOff for jump tables now.
 shortcutStatic _ other_static
@@ -69,6 +71,6 @@ shortBlockId
 
 shortBlockId fn blockid =
    case fn blockid of
-      Nothing -> mkAsmTempLabel uq
+      Nothing -> mkLocalBlockLabel uq
       Just (DestBlockId blockid')  -> shortBlockId fn blockid'
    where uq = getUnique blockid
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index a1befc7837..227517be88 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -50,6 +50,8 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Reg
 import RegClass
 import Format
@@ -70,7 +72,7 @@ import Data.Int         ( Int8, Int16, Int32, Int64 )
 -- squeese functions for the graph allocator -----------------------------------
 
 -- | regSqueeze_class reg
---      Calculuate the maximum number of register colors that could be
+--      Calculate the maximum number of register colors that could be
 --      denied to a node of this class due to having this reg
 --      as a neighbour.
 --
@@ -163,7 +165,7 @@ litToImm (CmmFloat f W32)    = ImmFloat f
 litToImm (CmmFloat f W64)    = ImmDouble f
 litToImm (CmmLabel l)        = ImmCLbl l
 litToImm (CmmLabelOff l off) = ImmIndex l off
-litToImm (CmmLabelDiffOff l1 l2 off)
+litToImm (CmmLabelDiffOff l1 l2 off _)
                              = ImmConstantSum
                                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
                                (ImmInt off)
diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs
index aca427449d..d96b18783d 100644
--- a/compiler/nativeGen/PprBase.hs
+++ b/compiler/nativeGen/PprBase.hs
@@ -16,6 +16,8 @@ module PprBase (
 
 where
 
+import GhcPrelude
+
 import AsmUtils
 import CLabel
 import Cmm
diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs
index 598074d881..d9d56d47c4 100644
--- a/compiler/nativeGen/Reg.hs
+++ b/compiler/nativeGen/Reg.hs
@@ -26,6 +26,8 @@ module Reg (
 
 where
 
+import GhcPrelude
+
 import Outputable
 import Unique
 import RegClass
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
index 6771e4ecb9..634e61cb13 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -21,6 +21,8 @@ module RegAlloc.Graph.ArchBase (
         bound,
         squeese
 ) where
+import GhcPrelude
+
 import UniqSet
 import UniqFM
 import Unique
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
index 439899071a..0472e4cf09 100644
--- a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
@@ -14,9 +14,14 @@ module RegAlloc.Graph.ArchX86 (
         worst,
         squeese,
 ) where
+
+import GhcPrelude
+
 import RegAlloc.Graph.ArchBase  (Reg(..), RegSub(..), RegClass(..))
 import UniqSet
 
+import qualified Data.Array as A
+
 
 -- | Determine the class of a register
 classOfReg :: Reg -> RegClass
@@ -57,18 +62,28 @@ regName :: Reg -> Maybe String
 regName reg
  = case reg of
         Reg ClassG32 i
-         | i <= 7-> Just $ [ "eax", "ebx", "ecx", "edx"
-                           , "ebp", "esi", "edi", "esp" ] !! i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "eax", "ebx", "ecx", "edx"
+                       , "ebp", "esi", "edi", "esp" ]
+           in Just $ names A.! i
 
         RegSub SubL16 (Reg ClassG32 i)
-         | i <= 7 -> Just $ [ "ax", "bx", "cx", "dx"
-                            , "bp", "si", "di", "sp"] !! i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "ax", "bx", "cx", "dx"
+                       , "bp", "si", "di", "sp"]
+           in Just $ names A.! i
 
         RegSub SubL8  (Reg ClassG32 i)
-         | i <= 3 -> Just $ [ "al", "bl", "cl", "dl"] !! i
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]
+           in Just $ names A.! i
 
         RegSub SubL8H (Reg ClassG32 i)
-         | i <= 3 -> Just $ [ "ah", "bh", "ch", "dh"] !! i
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]
+           in Just $ names A.! i
 
         _         -> Nothing
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 7e8047f29f..5ca2412c73 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -3,6 +3,8 @@ module RegAlloc.Graph.Coalesce (
         regCoalesce,
         slurpJoinMovs
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
@@ -14,8 +16,6 @@ import UniqFM
 import UniqSet
 import UniqSupply
 
-import Data.List
-
 
 -- | Do register coalescing on this top level thing
 --
@@ -62,7 +62,7 @@ sinkReg fm r
 
 -- | Slurp out mov instructions that only serve to join live ranges.
 --
---   During a mov, if the source reg dies and the destiation reg is
+--   During a mov, if the source reg dies and the destination reg is
 --   born then we can rename the two regs to the same thing and
 --   eliminate the move.
 slurpJoinMovs
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index 08538453f7..4c17d930ea 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -4,6 +4,8 @@
 module RegAlloc.Graph.Main (
         regAlloc
 ) where
+import GhcPrelude
+
 import qualified GraphColor as Color
 import RegAlloc.Liveness
 import RegAlloc.Graph.Spill
@@ -25,7 +27,6 @@ import UniqSet
 import UniqSupply
 import Util (seqList)
 
-import Data.List
 import Data.Maybe
 import Control.Monad
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 0014ab6fed..bce24bdd3c 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -7,6 +7,8 @@ module RegAlloc.Graph.Spill (
         SpillStats(..),
         accSpillSL
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
@@ -34,7 +36,7 @@ import qualified Data.IntSet    as IntSet
 --   TODO: See if we can split some of the live ranges instead of just globally
 --         spilling the virtual reg. This might make the spill cleaner's job easier.
 --
---   TODO: On CISCy x86 and x86_64 we don't nessesarally have to add a mov instruction
+--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
 --         when making spills. If an instr is using a spilled virtual we may be able to
 --         address the spill slot directly.
 --
@@ -111,8 +113,8 @@ regSpill_top platform regSlotMap cmm
                 -- after we've done a successful allocation.
                 let liveSlotsOnEntry' :: BlockMap IntSet
                     liveSlotsOnEntry'
-                        = mapFoldWithKey patchLiveSlot
-                                         liveSlotsOnEntry liveVRegsOnEntry
+                        = mapFoldlWithKey patchLiveSlot
+                                          liveSlotsOnEntry liveVRegsOnEntry
 
                 let info'
                         = LiveInfo static firstId
@@ -129,10 +131,9 @@ regSpill_top platform regSlotMap cmm
         -- then record the fact that these slots are now live in those blocks
         -- in the given slotmap.
         patchLiveSlot
-                :: BlockId -> RegSet
-                -> BlockMap IntSet -> BlockMap IntSet
+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
 
-        patchLiveSlot blockId regsLive slotMap
+        patchLiveSlot slotMap blockId regsLive
          = let
                 -- Slots that are already recorded as being live.
                 curSlotsLive    = fromMaybe IntSet.empty
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index faef4037c2..50001d7334 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -28,6 +28,8 @@
 module RegAlloc.Graph.SpillClean (
         cleanSpills
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 9811f1a64b..f603b609df 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -13,6 +13,8 @@ module RegAlloc.Graph.SpillCost (
 
         lifeMapFromSpillCostInfo
 ) where
+import GhcPrelude
+
 import RegAlloc.Liveness
 import Instruction
 import RegClass
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 71956025b0..487e3ee03a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -16,6 +16,8 @@ module RegAlloc.Graph.Stats (
 
 #include "nativeGen/NCG.h"
 
+import GhcPrelude
+
 import qualified GraphColor as Color
 import RegAlloc.Liveness
 import RegAlloc.Graph.Spill
@@ -32,9 +34,6 @@ import UniqFM
 import UniqSet
 import State
 
-import Data.List
-
-
 -- | Holds interesting statistics from the register allocator.
 data RegAllocStats statics instr
 
@@ -265,8 +264,8 @@ pprStatsConflict stats
         $$ text "\n")
 
 
--- | For every vreg, dump it's how many conflicts it has and its lifetime
---      good for making a scatter plot.
+-- | For every vreg, dump how many conflicts it has, and its lifetime.
+--      Good for making a scatter plot.
 pprStatsLifeConflict
         :: [RegAllocStats statics instr]
         -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
@@ -277,10 +276,10 @@ pprStatsLifeConflict stats graph
                 $ foldl' plusSpillCostInfo zeroSpillCostInfo
                 $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
 
-        scatter = map   (\r ->  let lifetime    = case lookupUFM lifeMap r of
-                                                        Just (_, l)     -> l
-                                                        Nothing         -> 0
-                                    Just node   = Color.lookupNode graph r
+        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of
+                                                      Just (_, l) -> l
+                                                      Nothing     -> 0
+                                    Just node = Color.lookupNode graph r
                                 in parens $ hcat $ punctuate (text ", ")
                                         [ doubleQuotes $ ppr $ Color.nodeId node
                                         , ppr $ sizeUniqSet (Color.nodeConflicts node)
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
index 204de846ae..7774985dce 100644
--- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -8,6 +8,8 @@ where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import RegClass
 import Reg
 
diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
index d4f124e297..1172870729 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Base.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -17,6 +17,8 @@ module RegAlloc.Linear.Base (
 
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.StackMap
 import RegAlloc.Liveness
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
index 9933f5bb49..b4e79432d8 100644
--- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -9,6 +9,8 @@ module RegAlloc.Linear.FreeRegs (
 
 where
 
+import GhcPrelude
+
 import Reg
 import RegClass
 
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index c262b2b059..89f496c409 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -9,6 +9,8 @@
 --
 module RegAlloc.Linear.JoinToTargets (joinToTargets) where
 
+import GhcPrelude
+
 import RegAlloc.Linear.State
 import RegAlloc.Linear.Base
 import RegAlloc.Linear.FreeRegs
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 2ba682ad17..6171d8d20d 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -102,6 +102,8 @@ module RegAlloc.Linear.Main (
 #include "HsVersions.h"
 
 
+import GhcPrelude
+
 import RegAlloc.Linear.State
 import RegAlloc.Linear.Base
 import RegAlloc.Linear.StackMap
@@ -496,7 +498,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
     -- debugging
 {-    freeregs <- getFreeRegsR
     assig    <- getAssigR
-    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform }) trace "genRaInsn"
+    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
         (ppr instr
                 $$ text "r_dying      = " <+> ppr r_dying
                 $$ text "w_dying      = " <+> ppr w_dying
@@ -807,27 +809,29 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
 
           -- case (3): we need to push something out to free up a register
          [] ->
-           do   let keep' = map getUnique keep
+           do   let inRegOrBoth (InReg _) = True
+                    inRegOrBoth (InBoth _ _) = True
+                    inRegOrBoth _ = False
+                let candidates' =
+                      flip delListFromUFM keep $
+                      filterUFM inRegOrBoth $
+                      assig
+                      -- This is non-deterministic but we do not
+                      -- currently support deterministic code-generation.
+                      -- See Note [Unique Determinism and code generation]
+                let candidates = nonDetUFMToList candidates'
 
                 -- the vregs we could kick out that are already in a slot
                 let candidates_inBoth
                         = [ (temp, reg, mem)
-                          | (temp, InBoth reg mem) <- nonDetUFMToList assig
-                          -- This is non-deterministic but we do not
-                          -- currently support deterministic code-generation.
-                          -- See Note [Unique Determinism and code generation]
-                          , temp `notElem` keep'
+                          | (temp, InBoth reg mem) <- candidates
                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
 
                 -- the vregs we could kick out that are only in a reg
                 --      this would require writing the reg to a new slot before using it.
                 let candidates_inReg
                         = [ (temp, reg)
-                          | (temp, InReg reg) <- nonDetUFMToList assig
-                          -- This is non-deterministic but we do not
-                          -- currently support deterministic code-generation.
-                          -- See Note [Unique Determinism and code generation]
-                          , temp `notElem` keep'
+                          | (temp, InReg reg) <- candidates
                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
 
                 let result
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
index 5d369249c7..581548212a 100644
--- a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -2,6 +2,8 @@
 module RegAlloc.Linear.PPC.FreeRegs
 where
 
+import GhcPrelude
+
 import PPC.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
index db4d6ba376..653b2707c9 100644
--- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.SPARC.FreeRegs
 where
 
+import GhcPrelude
+
 import SPARC.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
index 748fb98c30..95819c6fb3 100644
--- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -20,6 +20,8 @@ module RegAlloc.Linear.StackMap (
 
 where
 
+import GhcPrelude
+
 import DynFlags
 import UniqFM
 import Unique
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 8b17d3ab88..6554188f41 100644
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -31,6 +31,8 @@ module RegAlloc.Linear.State (
 )
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.Stats
 import RegAlloc.Linear.StackMap
 import RegAlloc.Linear.Base
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
index 71dedaeb55..74f3c834d0 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -6,6 +6,8 @@ module RegAlloc.Linear.Stats (
 
 where
 
+import GhcPrelude
+
 import RegAlloc.Linear.Base
 import RegAlloc.Liveness
 import Instruction
@@ -13,7 +15,6 @@ import Instruction
 import UniqFM
 import Outputable
 
-import Data.List
 import State
 
 -- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
index ae4aa53254..65a566d1c3 100644
--- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.X86.FreeRegs
 where
 
+import GhcPrelude
+
 import X86.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
index 5a7f71e3f0..713b053356 100644
--- a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
@@ -3,6 +3,8 @@
 module RegAlloc.Linear.X86_64.FreeRegs
 where
 
+import GhcPrelude
+
 import X86.Regs
 import RegClass
 import Reg
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index e66139786b..9d93564317 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -35,6 +35,8 @@ module RegAlloc.Liveness (
         regLiveness,
         natCmmTopToLive
   ) where
+import GhcPrelude
+
 import Reg
 import Instruction
 
@@ -145,10 +147,10 @@ instance Instruction instr => Instruction (InstrSR instr) where
         mkJumpInstr target      = map Instr (mkJumpInstr target)
 
         mkStackAllocInstr platform amount =
-             Instr (mkStackAllocInstr platform amount)
+             Instr <$> mkStackAllocInstr platform amount
 
         mkStackDeallocInstr platform amount =
-             Instr (mkStackDeallocInstr platform amount)
+             Instr <$> mkStackDeallocInstr platform amount
 
 
 -- | An instruction with liveness information.
@@ -812,7 +814,7 @@ computeLiveness
 computeLiveness platform sccs
  = case checkIsReverseDependent sccs of
         Nothing         -> livenessSCCs platform mapEmpty [] sccs
-        Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
+        Just bad        -> pprPanic "RegAlloc.Liveness.computeLiveness"
                                 (vcat   [ text "SCCs aren't in reverse dependent order"
                                         , text "bad blockId" <+> ppr bad
                                         , ppr sccs])
@@ -1006,5 +1008,3 @@ liveness1 platform liveregs blockmap (LiveInstr instr _)
             r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
                                              live_branch_only)
                           -- See Note [Unique Determinism and code generation]
-
-
diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs
index 0c793173cb..cd008bbbb1 100644
--- a/compiler/nativeGen/RegClass.hs
+++ b/compiler/nativeGen/RegClass.hs
@@ -4,6 +4,8 @@ module RegClass
 
 where
 
+import GhcPrelude
+
 import  Outputable
 import  Unique
 
diff --git a/compiler/nativeGen/SPARC/AddrMode.hs b/compiler/nativeGen/SPARC/AddrMode.hs
index bf4d480005..ee40843351 100644
--- a/compiler/nativeGen/SPARC/AddrMode.hs
+++ b/compiler/nativeGen/SPARC/AddrMode.hs
@@ -6,6 +6,8 @@ module SPARC.AddrMode (
 
 where
 
+import GhcPrelude
+
 import SPARC.Imm
 import SPARC.Base
 import Reg
diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs
index a57d5e1c9a..04e8fed2b3 100644
--- a/compiler/nativeGen/SPARC/Base.hs
+++ b/compiler/nativeGen/SPARC/Base.hs
@@ -18,6 +18,8 @@ module SPARC.Base (
 
 where
 
+import GhcPrelude
+
 import DynFlags
 import Panic
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 71d320fa63..a95a22274b 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -22,6 +22,8 @@ where
 #include "../includes/MachDeps.h"
 
 -- NCG stuff:
+import GhcPrelude
+
 import SPARC.Base
 import SPARC.CodeGen.Sanity
 import SPARC.CodeGen.Amode
@@ -58,7 +60,6 @@ import FastString
 import OrdList
 import Outputable
 import Platform
-import Unique
 
 import Control.Monad    ( mapAndUnzipM )
 
@@ -162,7 +163,7 @@ stmtToInstrs stmt = do
 
 
 {-
-Now, given a tree (the argument to an CmmLoad) that references memory,
+Now, given a tree (the argument to a CmmLoad) that references memory,
 produce a suitable addressing mode.
 
 A Rule of the Game (tm) for Amodes: use of the addr bit must
@@ -185,7 +186,7 @@ temporary, then do the other computation, and then use the temporary:
 jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
 jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
 jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel (getUnique blockid)
+    where blockLabel = blockLbl blockid
 
 
 
@@ -313,7 +314,7 @@ genCondJump bid bool = do
 
 genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
 genSwitch dflags expr targets
-        | gopt Opt_PIC dflags
+        | positionIndependent dflags
         = error "MachCodeGen: sparc genSwitch PIC not finished\n"
 
         | otherwise
@@ -422,7 +423,10 @@ genCCall target dest_regs args
                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
 
                 ForeignTarget expr _
-                 -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
+                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr
+                        let dyn_r = case dyn_rs of
+                                      [dyn_r'] -> dyn_r'
+                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
 
                 PrimTarget mop
@@ -432,7 +436,10 @@ genCCall target dest_regs args
                                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
 
                                 Right mopExpr -> do
-                                        (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
+                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
+                                        let dyn_r = case dyn_rs of
+                                                      [dyn_r'] -> dyn_r'
+                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
                                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
 
                         return lblOrMopExpr
@@ -626,6 +633,10 @@ outOfLineMachOp_table mop
         MO_F32_Cosh   -> fsLit "coshf"
         MO_F32_Tanh   -> fsLit "tanhf"
 
+        MO_F32_Asinh  -> fsLit "asinhf"
+        MO_F32_Acosh  -> fsLit "acoshf"
+        MO_F32_Atanh  -> fsLit "atanhf"
+
         MO_F64_Exp    -> fsLit "exp"
         MO_F64_Log    -> fsLit "log"
         MO_F64_Sqrt   -> fsLit "sqrt"
@@ -644,14 +655,21 @@ outOfLineMachOp_table mop
         MO_F64_Cosh   -> fsLit "cosh"
         MO_F64_Tanh   -> fsLit "tanh"
 
+        MO_F64_Asinh  -> fsLit "asinh"
+        MO_F64_Acosh  -> fsLit "acosh"
+        MO_F64_Atanh  -> fsLit "atanh"
+
         MO_UF_Conv w -> fsLit $ word2FloatLabel w
 
         MO_Memcpy _  -> fsLit "memcpy"
         MO_Memset _  -> fsLit "memset"
         MO_Memmove _ -> fsLit "memmove"
+        MO_Memcmp _  -> fsLit "memcmp"
 
         MO_BSwap w   -> fsLit $ bSwapLabel w
         MO_PopCnt w  -> fsLit $ popCntLabel w
+        MO_Pdep w    -> fsLit $ pdepLabel w
+        MO_Pext w    -> fsLit $ pextLabel w
         MO_Clz w     -> fsLit $ clzLabel w
         MO_Ctz w     -> fsLit $ ctzLabel w
         MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
@@ -663,6 +681,7 @@ outOfLineMachOp_table mop
         MO_U_QuotRem {}  -> unsupported
         MO_U_QuotRem2 {} -> unsupported
         MO_Add2 {}       -> unsupported
+        MO_AddWordC {}   -> unsupported
         MO_SubWordC {}   -> unsupported
         MO_AddIntC {}    -> unsupported
         MO_SubIntC {}    -> unsupported
diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
index a59287f171..33e3f535da 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
@@ -4,6 +4,8 @@ module SPARC.CodeGen.Amode (
 
 where
 
+import GhcPrelude
+
 import {-# SOURCE #-} SPARC.CodeGen.Gen32
 import SPARC.CodeGen.Base
 import SPARC.AddrMode
diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs
index 27b533f46b..039bb6496c 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Base.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs
@@ -13,6 +13,8 @@ module SPARC.CodeGen.Base (
 
 where
 
+import GhcPrelude
+
 import SPARC.Instr
 import SPARC.Cond
 import SPARC.AddrMode
diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
index e5fb82df4d..e6b2e174b6 100644
--- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
@@ -6,6 +6,8 @@ module SPARC.CodeGen.CondCode (
 
 where
 
+import GhcPrelude
+
 import {-# SOURCE #-} SPARC.CodeGen.Gen32
 import SPARC.CodeGen.Base
 import SPARC.Instr
diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
index 70cb0111c0..0b318740db 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
@@ -5,6 +5,8 @@ module SPARC.CodeGen.Expand (
 
 where
 
+import GhcPrelude
+
 import SPARC.Instr
 import SPARC.Imm
 import SPARC.AddrMode
@@ -140,7 +142,7 @@ expandMisalignedDoubles instr
 
 
 
--- | The the high partner for this float reg.
+-- | The high partner for this float reg.
 fRegHi :: Reg -> Reg
 fRegHi (RegReal (RealRegSingle r1))
         | r1            >= 32
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
index a0e86f14c4..a7a1f60416 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
@@ -6,6 +6,8 @@ module SPARC.CodeGen.Gen32 (
 
 where
 
+import GhcPrelude
+
 import SPARC.CodeGen.CondCode
 import SPARC.CodeGen.Amode
 import SPARC.CodeGen.Gen64
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
index f186d437d0..6fa7482f9b 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
@@ -7,6 +7,8 @@ module SPARC.CodeGen.Gen64 (
 
 where
 
+import GhcPrelude
+
 import {-# SOURCE #-} SPARC.CodeGen.Gen32
 import SPARC.CodeGen.Base
 import SPARC.CodeGen.Amode
@@ -191,6 +193,24 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
 
         return  $ ChildCode64 code r_dst_lo
 
+-- only W32 supported for now
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])
+ = do
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        -- compute expr and load it into r_dst_lo
+        (a_reg, a_code) <- getSomeReg expr
+
+        dflags          <- getDynFlags
+        let platform    = targetPlatform dflags
+            code        = a_code
+                `appOL` toOL
+                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi
+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]
+
+        return  $ ChildCode64 code r_dst_lo
+
 
 iselExpr64 expr
    = pprPanic "iselExpr64(sparc)" (ppr expr)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
index 81641326f2..fcf5b65bde 100644
--- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -6,6 +6,8 @@ module SPARC.CodeGen.Sanity (
 
 where
 
+import GhcPrelude
+
 import SPARC.Instr
 import SPARC.Ppr        ()
 import Instruction
diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs
index da41457950..3fbfb8603f 100644
--- a/compiler/nativeGen/SPARC/Cond.hs
+++ b/compiler/nativeGen/SPARC/Cond.hs
@@ -7,6 +7,8 @@ module SPARC.Cond (
 
 where
 
+import GhcPrelude
+
 -- | Branch condition codes.
 data Cond
         = ALWAYS
diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs
index cb53ba411c..bd2d4ab131 100644
--- a/compiler/nativeGen/SPARC/Imm.hs
+++ b/compiler/nativeGen/SPARC/Imm.hs
@@ -7,6 +7,8 @@ module SPARC.Imm (
 
 where
 
+import GhcPrelude
+
 import Cmm
 import CLabel
 
@@ -57,7 +59,7 @@ litToImm lit
         CmmLabel l              -> ImmCLbl l
         CmmLabelOff l off       -> ImmIndex l off
 
-        CmmLabelDiffOff l1 l2 off
+        CmmLabelDiffOff l1 l2 off _
          -> ImmConstantSum
                 (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
                 (ImmInt off)
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 4c19ac69a7..54fb513478 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -25,6 +25,8 @@ module SPARC.Instr (
 
 where
 
+import GhcPrelude
+
 import SPARC.Stack
 import SPARC.Imm
 import SPARC.AddrMode
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 88b04b952a..eb401fff06 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -25,6 +25,8 @@ where
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
+import GhcPrelude
+
 import SPARC.Regs
 import SPARC.Instr
 import SPARC.Cond
@@ -38,11 +40,12 @@ import PprBase
 
 import Cmm hiding (topInfoTable)
 import PprCmm()
+import BlockId
 import CLabel
 import Hoopl.Label
 import Hoopl.Collections
 
-import Unique           ( Uniquable(..), pprUniqueAlways )
+import Unique           ( pprUniqueAlways )
 import Outputable
 import Platform
 import FastString
@@ -91,7 +94,7 @@ dspSection = Section Text $
 pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
 pprBasicBlock info_env (BasicBlock blockid instrs)
   = maybe_infotable $$
-    pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+    pprLabel (blockLbl blockid) $$
     vcat (map pprInstr instrs)
   where
     maybe_infotable = case mapLookup blockid info_env of
@@ -402,7 +405,7 @@ pprInstr (LD format addr reg)
                pprReg reg
             ]
 
--- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand
+-- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand
 pprInstr (ST FF64 reg _)
         | RegReal (RealRegSingle{}) <- reg
         = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"
@@ -541,7 +544,7 @@ pprInstr (BI cond b blockid)
         text "\tb", pprCond cond,
         if b then pp_comma_a else empty,
         char '\t',
-        ppr (mkAsmTempLabel (getUnique blockid))
+        ppr (blockLbl blockid)
     ]
 
 pprInstr (BF cond b blockid)
@@ -549,7 +552,7 @@ pprInstr (BF cond b blockid)
         text "\tfb", pprCond cond,
         if b then pp_comma_a else empty,
         char '\t',
-        ppr (mkAsmTempLabel (getUnique blockid))
+        ppr (blockLbl blockid)
     ]
 
 pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr
diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs
index 14a5192c2d..d6aadbae94 100644
--- a/compiler/nativeGen/SPARC/Regs.hs
+++ b/compiler/nativeGen/SPARC/Regs.hs
@@ -32,6 +32,8 @@ module SPARC.Regs (
 where
 
 
+import GhcPrelude
+
 import CodeGen.Platform.SPARC
 import Reg
 import RegClass
@@ -75,7 +77,7 @@ classOfRealReg reg
 
 
 -- | regSqueeze_class reg
---      Calculuate the maximum number of register colors that could be
+--      Calculate the maximum number of register colors that could be
 --      denied to a node of this class due to having this reg
 --      as a neighbour.
 --
@@ -191,7 +193,7 @@ fPair reg
 
 
 -- | All the regs that the register allocator can allocate to,
---      with the the fixed use regs removed.
+--      with the fixed use regs removed.
 --
 allocatableRegs :: [RealReg]
 allocatableRegs
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
index 123a345130..83e366cb04 100644
--- a/compiler/nativeGen/SPARC/ShortcutJump.hs
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -8,6 +8,8 @@ module SPARC.ShortcutJump (
 
 where
 
+import GhcPrelude
+
 import SPARC.Instr
 import SPARC.Imm
 
@@ -16,8 +18,6 @@ import BlockId
 import Cmm
 
 import Panic
-import Unique
-
 
 
 data JumpDest
@@ -46,14 +46,14 @@ shortcutStatics fn (Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
         = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
-        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
 -- slightly dodgy, we're ignoring the second label, but this
 -- works with the way we use CmmLabelDiffOff for jump tables now.
 shortcutStatic _ other_static
@@ -63,7 +63,7 @@ shortcutStatic _ other_static
 shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel
 shortBlockId fn blockid =
    case fn blockid of
-      Nothing -> mkAsmTempLabel (getUnique blockid)
+      Nothing -> blockLbl blockid
       Just (DestBlockId blockid')  -> shortBlockId fn blockid'
       Just (DestImm (ImmCLbl lbl)) -> lbl
       _other -> panic "shortBlockId"
diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs
index 629b18789f..3f5b2a7289 100644
--- a/compiler/nativeGen/SPARC/Stack.hs
+++ b/compiler/nativeGen/SPARC/Stack.hs
@@ -7,6 +7,8 @@ module SPARC.Stack (
 
 where
 
+import GhcPrelude
+
 import SPARC.AddrMode
 import SPARC.Regs
 import SPARC.Base
diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs
index a298cccaf6..6800b9043b 100644
--- a/compiler/nativeGen/TargetReg.hs
+++ b/compiler/nativeGen/TargetReg.hs
@@ -21,6 +21,8 @@ where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Reg
 import RegClass
 import Format
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 341fa43dbc..a2e26bd68b 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -2,9 +2,7 @@
 
 -- The default iteration limit is a bit too low for the definitions
 -- in this module.
-#if __GLASGOW_HASKELL__ >= 800
 {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-#endif
 
 -----------------------------------------------------------------------------
 --
@@ -32,6 +30,8 @@ where
 #include "../includes/MachDeps.h"
 
 -- NCG stuff:
+import GhcPrelude
+
 import X86.Instr
 import X86.Cond
 import X86.Regs
@@ -65,7 +65,6 @@ import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
 import ForeignCall      ( CCallConv(..) )
 import OrdList
 import Outputable
-import Unique
 import FastString
 import DynFlags
 import Util
@@ -211,6 +210,9 @@ stmtToInstrs stmt = do
        -> genCCall dflags is32Bit target result_regs args
 
     CmmBranch id          -> genBranch id
+
+    --We try to arrange blocks such that the likely branch is the fallthrough
+    --in CmmContFlowOpt. So we can assume the condition is likely false here.
     CmmCondBranch arg true false _ -> do
       b1 <- genCondJump true arg
       b2 <- genBranch false
@@ -295,7 +297,7 @@ data Amode
         = Amode AddrMode InstrBlock
 
 {-
-Now, given a tree (the argument to an CmmLoad) that references memory,
+Now, given a tree (the argument to a CmmLoad) that references memory,
 produce a suitable addressing mode.
 
 A Rule of the Game (tm) for Amodes: use of the addr bit must
@@ -328,7 +330,7 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
 jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
 jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
 jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel (getUnique blockid)
+    where blockLabel = blockLbl blockid
 
 
 -- -----------------------------------------------------------------------------
@@ -466,6 +468,20 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
                           r_dst_lo
             )
 
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+     fn <- getAnyReg expr
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         code = fn r_dst_lo
+     return (
+             ChildCode64 (code `snocOL`
+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`
+                          CLTD II32 `snocOL`
+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`
+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))
+                          r_dst_lo
+            )
+
 iselExpr64 expr
    = pprPanic "iselExpr64(i386)" (ppr expr)
 
@@ -503,6 +519,9 @@ getRegister' dflags is32Bit (CmmReg reg)
 getRegister' dflags is32Bit (CmmRegOff r n)
   = getRegister' dflags is32Bit $ mangleIndexTree dflags r n
 
+getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
+  = addAlignmentCheck align <$> getRegister' dflags is32Bit e
+
 -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
 -- TO_W_(x), TO_W_(x >> 32)
 
@@ -731,8 +750,10 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
       MO_F_Ne _ -> condFltReg is32Bit NE  x y
       MO_F_Gt _ -> condFltReg is32Bit GTT x y
       MO_F_Ge _ -> condFltReg is32Bit GE  x y
-      MO_F_Lt _ -> condFltReg is32Bit LTT x y
-      MO_F_Le _ -> condFltReg is32Bit LE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x
+      MO_F_Le _ -> condFltReg is32Bit GE   y x
 
       MO_Eq _   -> condIntReg EQQ x y
       MO_Ne _   -> condIntReg NE  x y
@@ -1255,6 +1276,21 @@ isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit
                           || isSuitableFloatingPointLit lit
 isOperand _ _            = False
 
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation@.
+addAlignmentCheck :: Int -> Register -> Register
+addAlignmentCheck align reg =
+    case reg of
+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)
+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)
+  where
+    check :: Format -> Reg -> InstrBlock
+    check fmt reg =
+        ASSERT(not $ isFloatFormat fmt)
+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
+             ]
+
 memConstant :: Int -> CmmLit -> NatM Amode
 memConstant align lit = do
   lbl <- getNewLabelNat
@@ -1331,15 +1367,17 @@ getCondCode (CmmMachOp mop [x, y])
       MO_F_Ne W32 -> condFltCode NE  x y
       MO_F_Gt W32 -> condFltCode GTT x y
       MO_F_Ge W32 -> condFltCode GE  x y
-      MO_F_Lt W32 -> condFltCode LTT x y
-      MO_F_Le W32 -> condFltCode LE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt W32 -> condFltCode GTT  y x
+      MO_F_Le W32 -> condFltCode GE   y x
 
       MO_F_Eq W64 -> condFltCode EQQ x y
       MO_F_Ne W64 -> condFltCode NE  x y
       MO_F_Gt W64 -> condFltCode GTT x y
       MO_F_Ge W64 -> condFltCode GE  x y
-      MO_F_Lt W64 -> condFltCode LTT x y
-      MO_F_Le W64 -> condFltCode LE  x y
+      MO_F_Lt W64 -> condFltCode GTT y x
+      MO_F_Le W64 -> condFltCode GE  y x
 
       _ -> condIntCode (machOpToCond mop) x y
 
@@ -1639,11 +1677,19 @@ genCondJump' _ id bool = do
     else do
         lbl <- getBlockIdNat
 
-        -- see comment with condFltReg
+        -- See Note [SSE Parity Checks]
         let code = case cond of
                         NE  -> or_unordered
                         GU  -> plain_test
                         GEU -> plain_test
+                        -- Use ASSERT so we don't break releases if
+                        -- LTT/LE creep in somehow.
+                        LTT ->
+                          ASSERT2(False, ppr "Should have been turned into >")
+                          and_ordered
+                        LE  ->
+                          ASSERT2(False, ppr "Should have been turned into >=")
+                          and_ordered
                         _   -> and_ordered
 
             plain_test = unitOL (
@@ -1855,6 +1901,72 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
     format = intFormat width
     lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
 
+genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
+         args@[src, mask] = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PDEP instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)
+                     else
+                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
+         args@[src, mask] = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PEXT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)
+                     else
+                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))
+
 genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
   | is32Bit && width == W64 = do
     -- Fallback to `hs_clz64` on i386
@@ -2129,6 +2241,8 @@ genCCall _ is32Bit target dest_regs args = do
                           ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
                return code
         _ -> panic "genCCall: Wrong number of arguments/results for add2"
+    (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->
+        addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args
     (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->
         addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args
     (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->
@@ -2645,6 +2759,10 @@ outOfLineCmmOp mop res args
               MO_F32_Tanh  -> fsLit "tanhf"
               MO_F32_Pwr   -> fsLit "powf"
 
+              MO_F32_Asinh -> fsLit "asinhf"
+              MO_F32_Acosh -> fsLit "acoshf"
+              MO_F32_Atanh -> fsLit "atanhf"
+
               MO_F64_Sqrt  -> fsLit "sqrt"
               MO_F64_Fabs  -> fsLit "fabs"
               MO_F64_Sin   -> fsLit "sin"
@@ -2662,15 +2780,23 @@ outOfLineCmmOp mop res args
               MO_F64_Tanh  -> fsLit "tanh"
               MO_F64_Pwr   -> fsLit "pow"
 
+              MO_F64_Asinh  -> fsLit "asinh"
+              MO_F64_Acosh  -> fsLit "acosh"
+              MO_F64_Atanh  -> fsLit "atanh"
+
               MO_Memcpy _  -> fsLit "memcpy"
               MO_Memset _  -> fsLit "memset"
               MO_Memmove _ -> fsLit "memmove"
+              MO_Memcmp _  -> fsLit "memcmp"
 
               MO_PopCnt _  -> fsLit "popcnt"
               MO_BSwap _   -> fsLit "bswap"
               MO_Clz w     -> fsLit $ clzLabel w
               MO_Ctz _     -> unsupported
 
+              MO_Pdep w    -> fsLit $ pdepLabel w
+              MO_Pext w    -> fsLit $ pextLabel w
+
               MO_AtomicRMW _ _ -> fsLit "atomicrmw"
               MO_AtomicRead _  -> fsLit "atomicread"
               MO_AtomicWrite _ -> fsLit "atomicwrite"
@@ -2684,6 +2810,7 @@ outOfLineCmmOp mop res args
               MO_Add2 {}       -> unsupported
               MO_AddIntC {}    -> unsupported
               MO_SubIntC {}    -> unsupported
+              MO_AddWordC {}   -> unsupported
               MO_SubWordC {}   -> unsupported
               MO_U_Mul2 {}     -> unsupported
               MO_WriteBarrier  -> unsupported
@@ -2698,7 +2825,7 @@ outOfLineCmmOp mop res args
 genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
 
 genSwitch dflags expr targets
-  | gopt Opt_PIC dflags
+  | positionIndependent dflags
   = do
         (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)
            -- getNonClobberedReg because it needs to survive across t_code
@@ -2750,23 +2877,29 @@ genSwitch dflags expr targets
                     JMP_TBL op ids (Section ReadOnlyData lbl) lbl
                  ]
         return code
-  where (offset, ids) = switchTargetsToTable targets
+  where
+    (offset, blockIds) = switchTargetsToTable targets
+    ids = map (fmap DestBlockId) blockIds
 
 generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
 generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl)
-    = Just (createJumpTable dflags ids section lbl)
+    = let getBlockId (DestBlockId id) = id
+          getBlockId _ = panic "Non-Label target in Jump Table"
+          blockIds = map (fmap getBlockId) ids
+      in Just (createJumpTable dflags blockIds section lbl)
 generateJumpTableForInstr _ _ = Nothing
 
 createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel
                 -> GenCmmDecl (Alignment, CmmStatics) h g
 createJumpTable dflags ids section lbl
     = let jumpTable
-            | gopt Opt_PIC dflags =
-                  let jumpTableEntryRel Nothing
-                          = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+            | positionIndependent dflags =
+                  let ww = wordWidth dflags
+                      jumpTableEntryRel Nothing
+                          = CmmStaticLit (CmmInt 0 ww)
                       jumpTableEntryRel (Just blockid)
-                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                          where blockLabel = mkAsmTempLabel (getUnique blockid)
+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)
+                          where blockLabel = blockLbl blockid
                   in map jumpTableEntryRel ids
             | otherwise = map (jumpTableEntry dflags) ids
       in CmmData section (1, Statics lbl jumpTable)
@@ -2797,6 +2930,59 @@ condIntReg cond x y = do
   return (Any II32 code)
 
 
+-----------------------------------------------------------
+---          Note [SSE Parity Checks]                   ---
+-----------------------------------------------------------
+
+-- We have to worry about unordered operands (eg. comparisons
+-- against NaN).  If the operands are unordered, the comparison
+-- sets the parity flag, carry flag and zero flag.
+-- All comparisons are supposed to return false for unordered
+-- operands except for !=, which returns true.
+--
+-- Optimisation: we don't have to test the parity flag if we
+-- know the test has already excluded the unordered case: eg >
+-- and >= test for a zero carry flag, which can only occur for
+-- ordered operands.
+--
+-- By reversing comparisons we can avoid testing the parity
+-- for < and <= as well. If any of the arguments is an NaN we
+-- return false either way. If both arguments are valid then
+-- x <= y  <->  y >= x  holds. So it's safe to swap these.
+--
+-- We invert the condition inside getRegister'and  getCondCode
+-- which should cover all invertable cases.
+-- All other functions translating FP comparisons to assembly
+-- use these to two generate the comparison code.
+--
+-- As an example consider a simple check:
+--
+-- func :: Float -> Float -> Int
+-- func x y = if x < y then 1 else 0
+--
+-- Which in Cmm gives the floating point comparison.
+--
+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;
+--
+-- We used to compile this to an assembly code block like this:
+-- _c2gh:
+--  ucomiss %xmm2,%xmm1
+--  jp _c2gf
+--  jb _c2gg
+--  jmp _c2gf
+--
+-- Where we have to introduce an explicit
+-- check for unordered results (using jmp parity):
+--
+-- We can avoid this by exchanging the arguments and inverting the direction
+-- of the comparison. This results in the sequence of:
+--
+--  ucomiss %xmm1,%xmm2
+--  ja _c2g2
+--  jmp _c2g1
+--
+-- Removing the jump reduces the pressure on the branch predidiction system
+-- and plays better with the uOP cache.
 
 condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
 condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87
@@ -2815,27 +3001,18 @@ condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87
     CondCode _ cond cond_code <- condFltCode cond x y
     tmp1 <- getNewRegNat (archWordFormat is32Bit)
     tmp2 <- getNewRegNat (archWordFormat is32Bit)
-    let
-        -- We have to worry about unordered operands (eg. comparisons
-        -- against NaN).  If the operands are unordered, the comparison
-        -- sets the parity flag, carry flag and zero flag.
-        -- All comparisons are supposed to return false for unordered
-        -- operands except for !=, which returns true.
-        --
-        -- Optimisation: we don't have to test the parity flag if we
-        -- know the test has already excluded the unordered case: eg >
-        -- and >= test for a zero carry flag, which can only occur for
-        -- ordered operands.
-        --
-        -- ToDo: by reversing comparisons we could avoid testing the
-        -- parity flag in more cases.
-
+    let -- See Note [SSE Parity Checks]
         code dst =
            cond_code `appOL`
              (case cond of
                 NE  -> or_unordered dst
                 GU  -> plain_test   dst
                 GEU -> plain_test   dst
+                -- Use ASSERT so we don't break releases if these creep in.
+                LTT -> ASSERT2(False, ppr "Should have been turned into >")
+                       and_ordered  dst
+                LE  -> ASSERT2(False, ppr "Should have been turned into >=")
+                       and_ordered  dst
                 _   -> and_ordered  dst)
 
         plain_test dst = toOL [
diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs
index 586dabd8f4..35cbf943e1 100644
--- a/compiler/nativeGen/X86/Cond.hs
+++ b/compiler/nativeGen/X86/Cond.hs
@@ -8,6 +8,8 @@ module X86.Cond (
 
 where
 
+import GhcPrelude
+
 data Cond
         = ALWAYS        -- What's really used? ToDo
         | EQQ
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 71f50e9d2a..c7000c9f4b 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -8,7 +8,7 @@
 --
 -----------------------------------------------------------------------------
 
-module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest,
+module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),
                   getJumpDestBlockId, canShortcut, shortcutStatics,
                   shortcutJump, i386_insert_ffrees, allocMoreStack,
                   maxSpillSlots, archWordFormat)
@@ -17,6 +17,8 @@ where
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
+import GhcPrelude
+
 import X86.Cond
 import X86.Regs
 import Instruction
@@ -320,7 +322,7 @@ data Instr
         | JXX_GBL     Cond Imm      -- non-local version of JXX
         -- Table jump
         | JMP_TBL     Operand   -- Address to jump to
-                      [Maybe BlockId] -- Blocks in the jump table
+                      [Maybe JumpDest] -- Targets of the jump table
                       Section   -- Data section jump table should be put in
                       CLabel    -- Label of jump table
         | CALL        (Either Imm Reg) [Reg]
@@ -343,6 +345,10 @@ data Instr
         | BSF         Format Operand Reg -- bit scan forward
         | BSR         Format Operand Reg -- bit scan reverse
 
+    -- bit manipulation instructions
+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask
+
     -- prefetch
         | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
                                         -- variant can be NTA, Lvl0, Lvl1, or Lvl2
@@ -462,6 +468,9 @@ x86_regUsageOfInstr platform instr
     BSF    _ src dst -> mkRU (use_R src []) [dst]
     BSR    _ src dst -> mkRU (use_R src []) [dst]
 
+    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+
     -- note: might be a better way to do this
     PREFETCH _  _ src -> mkRU (use_R src []) []
     LOCK i              -> x86_regUsageOfInstr platform i
@@ -638,6 +647,8 @@ x86_patchRegsOfInstr instr env
     CLTD _              -> instr
 
     POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)
+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)
     BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)
     BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)
 
@@ -693,7 +704,7 @@ x86_jumpDestsOfInstr
 x86_jumpDestsOfInstr insn
   = case insn of
         JXX _ id        -> [id]
-        JMP_TBL _ ids _ _ -> [id | Just id <- ids]
+        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
         _               -> []
 
 
@@ -704,8 +715,12 @@ x86_patchJumpInstr insn patchF
   = case insn of
         JXX cc id       -> JXX cc (patchF id)
         JMP_TBL op ids section lbl
-          -> JMP_TBL op (map (fmap patchF) ids) section lbl
+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl
         _               -> insn
+    where
+        patchJumpDest f (DestBlockId id) = DestBlockId (f id)
+        patchJumpDest _ dest             = dest
+
 
 
 
@@ -843,25 +858,104 @@ x86_mkJumpInstr
 x86_mkJumpInstr id
         = [JXX ALWAYS id]
 
+-- Note [Windows stack layout]
+-- | On most OSes the kernel will place a guard page after the current stack
+--   page.  If you allocate larger than a page worth you may jump over this
+--   guard page.  Not only is this a security issue, but on certain OSes such
+--   as Windows a new page won't be allocated if you don't hit the guard.  This
+--   will cause a segfault or access fault.
+--
+--   This function defines if the current allocation amount requires a probe.
+--   On Windows (for now) we emit a call to _chkstk for this.  For other OSes
+--   this is not yet implemented.
+--   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk
+--   The Windows stack looks like this:
+--
+--                         +-------------------+
+--                         |        SP         |
+--                         +-------------------+
+--                         |                   |
+--                         |    GUARD PAGE     |
+--                         |                   |
+--                         +-------------------+
+--                         |                   |
+--                         |                   |
+--                         |     UNMAPPED      |
+--                         |                   |
+--                         |                   |
+--                         +-------------------+
+--
+--   In essense each allocation larger than a page size needs to be chunked and
+--   a probe emitted after each page allocation.  You have to hit the guard
+--   page so the kernel can map in the next page, otherwise you'll segfault.
+--
+needs_probe_call :: Platform -> Int -> Bool
+needs_probe_call platform amount
+  = case platformOS platform of
+     OSMinGW32 -> case platformArch platform of
+                    ArchX86    -> amount > (4 * 1024)
+                    ArchX86_64 -> amount > (8 * 1024)
+                    _          -> False
+     _         -> False
 
 x86_mkStackAllocInstr
         :: Platform
         -> Int
-        -> Instr
+        -> [Instr]
 x86_mkStackAllocInstr platform amount
-  = case platformArch platform of
-      ArchX86    -> SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
-      ArchX86_64 -> SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
-      _ -> panic "x86_mkStackAllocInstr"
+  = case platformOS platform of
+      OSMinGW32 ->
+        -- These will clobber AX but this should be ok because
+        --
+        -- 1. It is the first thing we do when entering the closure and AX is
+        --    a caller saved registers on Windows both on x86_64 and x86.
+        --
+        -- 2. The closures are only entered via a call or longjmp in which case
+        --    there are no expectations for volatile registers.
+        --
+        -- 3. When the target is a local branch point it is re-targeted
+        --    after the dealloc, preserving #2.  See note [extra spill slots].
+        --
+        -- We emit a call because the stack probes are quite involved and
+        -- would bloat code size a lot.  GHC doesn't really have an -Os.
+        -- __chkstk is guaranteed to leave all nonvolatile registers and AX
+        -- untouched.  It's part of the standard prologue code for any Windows
+        -- function dropping the stack more than a page.
+        -- See Note [Windows stack layout]
+        case platformArch platform of
+            ArchX86    | needs_probe_call platform amount ->
+                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)
+                           , CALL (Left $ strImmLit "___chkstk_ms") [eax]
+                           , SUB II32 (OpReg eax) (OpReg esp)
+                           ]
+                       | otherwise ->
+                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
+                           , TEST II32 (OpReg esp) (OpReg esp)
+                           ]
+            ArchX86_64 | needs_probe_call platform amount ->
+                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
+                           , CALL (Left $ strImmLit "__chkstk_ms") [rax]
+                           , SUB II64 (OpReg rax) (OpReg rsp)
+                           ]
+                       | otherwise ->
+                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
+                           , TEST II64 (OpReg rsp) (OpReg rsp)
+                           ]
+            _ -> panic "x86_mkStackAllocInstr"
+      _       ->
+        case platformArch platform of
+          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]
+          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]
+          _ -> panic "x86_mkStackAllocInstr"
 
 x86_mkStackDeallocInstr
         :: Platform
         -> Int
-        -> Instr
+        -> [Instr]
 x86_mkStackDeallocInstr platform amount
   = case platformArch platform of
-      ArchX86    -> ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
-      ArchX86_64 -> ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)
+      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]
+      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]
       _ -> panic "x86_mkStackDeallocInstr"
 
 i386_insert_ffrees
@@ -981,7 +1075,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
 
       insert_stack_insns (BasicBlock id insns)
          | Just new_blockid <- mapLookup id new_blockmap
-         = [ BasicBlock id [alloc, JXX ALWAYS new_blockid]
+         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]
            , BasicBlock new_blockid block' ]
          | otherwise
          = [ BasicBlock id block' ]
@@ -989,7 +1083,7 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
            block' = foldr insert_dealloc [] insns
 
       insert_dealloc insn r = case insn of
-         JMP _ _     -> dealloc : insn : r
+         JMP _ _     -> dealloc ++ (insn : r)
          JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"
          _other      -> x86_patchJumpInstr insn retarget : r
            where retarget b = fromMaybe b (mapLookup b new_blockmap)
@@ -998,7 +1092,6 @@ allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
     -- in
     return (CmmProc info lbl live (ListGraph new_code))
 
-
 data JumpDest = DestBlockId BlockId | DestImm Imm
 
 getJumpDestBlockId :: JumpDest -> Maybe BlockId
@@ -1015,14 +1108,24 @@ canShortcut _                    = Nothing
 -- The blockset helps avoid following cycles.
 shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
 shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
-  where shortcutJump' fn seen insn@(JXX cc id) =
-          if setMember id seen then insn
-          else case fn id of
-                 Nothing                -> insn
-                 Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
-                 Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
-               where seen' = setInsert id seen
-        shortcutJump' _ _ other = other
+  where
+    shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
+    shortcutJump' fn seen insn@(JXX cc id) =
+        if setMember id seen then insn
+        else case fn id of
+            Nothing                -> insn
+            Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
+            Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
+        where seen' = setInsert id seen
+    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =
+        let updateBlock (Just (DestBlockId bid))  =
+                case fn bid of
+                    Nothing   -> Just (DestBlockId bid )
+                    Just dest -> Just dest
+            updateBlock dest = dest
+            blocks' = map updateBlock blocks
+        in  JMP_TBL addr blocks' section tblId
+    shortcutJump' _ _ other = other
 
 -- Here because it knows about JumpDest
 shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
@@ -1033,14 +1136,14 @@ shortcutStatics fn (align, Statics lbl statics)
 
 shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
 shortcutLabel fn lab
-  | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq)
-  | otherwise                   = lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
+  | otherwise                              = lab
 
 shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
 shortcutStatic fn (CmmStaticLit (CmmLabel lab))
   = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
-  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off)
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
         -- slightly dodgy, we're ignoring the second label, but this
         -- works with the way we use CmmLabelDiffOff for jump tables now.
 shortcutStatic _ other_static
@@ -1054,8 +1157,8 @@ shortBlockId
 
 shortBlockId fn seen blockid =
   case (elementOfUniqSet uq seen, fn blockid) of
-    (True, _)    -> mkAsmTempLabel uq
-    (_, Nothing) -> mkAsmTempLabel uq
+    (True, _)    -> blockLbl blockid
+    (_, Nothing) -> blockLbl blockid
     (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
     (_, Just (DestImm (ImmCLbl lbl))) -> lbl
     (_, _other) -> panic "shortBlockId"
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index fce432a3dc..03d4fce794 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -23,6 +23,8 @@ where
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
 
+import GhcPrelude
+
 import X86.Regs
 import X86.Instr
 import X86.Cond
@@ -37,8 +39,9 @@ import Hoopl.Label
 import BasicTypes       (Alignment)
 import DynFlags
 import Cmm              hiding (topInfoTable)
+import BlockId
 import CLabel
-import Unique           ( pprUniqueAlways, Uniquable(..) )
+import Unique           ( pprUniqueAlways )
 import Platform
 import FastString
 import Outputable
@@ -70,12 +73,17 @@ import Data.Bits
 -- .subsections_via_symbols and -dead_strip can be found at
 -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>
 
+pprProcAlignment :: SDoc
+pprProcAlignment = sdocWithDynFlags $ \dflags ->
+  (maybe empty pprAlign . cmmProcAlignment $ dflags)
+
 pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionAlign section $$ pprDatas dats
 
 pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
   sdocWithDynFlags $ \dflags ->
+  pprProcAlignment $$
   case topInfoTable proc of
     Nothing ->
        case blocks of
@@ -83,6 +91,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
            pprLabel lbl
          blocks -> -- special case for code without info table:
            pprSectionAlign (Section Text lbl) $$
+           pprProcAlignment $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
            vcat (map (pprBasicBlock top_info) blocks) $$
            (if debugLevel dflags > 0
@@ -92,6 +101,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
     Just (Statics info_lbl _) ->
       sdocWithPlatform $ \platform ->
       pprSectionAlign (Section Text info_lbl) $$
+      pprProcAlignment $$
       (if platformHasSubsectionsViaSymbols platform
           then ppr (mkDeadStripPreventer info_lbl) <> char ':'
           else empty) $$
@@ -126,7 +136,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
     (if debugLevel dflags > 0
      then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
   where
-    asmLbl = mkAsmTempLabel (getUnique blockid)
+    asmLbl = blockLbl blockid
     maybe_infotable = case mapLookup blockid info_env of
        Nothing   -> empty
        Just (Statics info_lbl info) ->
@@ -160,35 +170,116 @@ pprGloblDecl lbl
   | not (externallyVisibleCLabel lbl) = empty
   | otherwise = text ".globl " <> ppr lbl
 
-pprTypeAndSizeDecl :: CLabel -> SDoc
-pprTypeAndSizeDecl lbl
+pprLabelType' :: DynFlags -> CLabel -> SDoc
+pprLabelType' dflags lbl =
+  if isCFunctionLabel lbl || functionOkInfoTable then
+    text "@function"
+  else
+    text "@object"
+  where
+    {-
+    NOTE: This is a bit hacky.
+
+    With the `tablesNextToCode` info tables look like this:
+    ```
+      <info table data>
+    label_info:
+      <info table code>
+    ```
+    So actually info table label points exactly to the code and we can mark
+    the label as @function. (This is required to make perf and potentially other
+    tools to work on Haskell binaries).
+    This usually works well but it can cause issues with a linker.
+    A linker uses different algorithms for the relocation depending on
+    the symbol type.For some reason, a linker will generate JUMP_SLOT relocation
+    when constructor info table is referenced from a data section.
+    This only happens with static constructor call so
+    we mark _con_info symbols as `@object` to avoid the issue with relocations.
+
+    @SimonMarlow hack explanation:
+    "The reasoning goes like this:
+
+    * The danger when we mark a symbol as `@function` is that the linker will
+      redirect it to point to the PLT and use a `JUMP_SLOT` relocation when
+      the symbol refers to something outside the current shared object.
+      A PLT / JUMP_SLOT reference only works for symbols that we jump to, not
+      for symbols representing data,, nor for info table symbol references which
+      we expect to point directly to the info table.
+    * GHC generates code that might refer to any info table symbol from the text
+      segment, but that's OK, because those will be explicit GOT references
+      generated by the code generator.
+    * When we refer to info tables from the data segment, it's either
+      * a FUN_STATIC/THUNK_STATIC local to this module
+      * a `con_info` that could be from anywhere
+
+    So, the only info table symbols that we might refer to from the data segment
+    of another shared object are `con_info` symbols, so those are the ones we
+    need to exclude from getting the @function treatment.
+    "
+
+    A good place to check for more
+    https://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode
+
+    Another possible hack is to create an extra local function symbol for
+    every code-like thing to give the needed information for to the tools
+    but mess up with the relocation. https://phabricator.haskell.org/D4730
+    -}
+    functionOkInfoTable = tablesNextToCode dflags &&
+      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)
+
+
+pprTypeDecl :: CLabel -> SDoc
+pprTypeDecl lbl
     = sdocWithPlatform $ \platform ->
       if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
-      then text ".type " <> ppr lbl <> ptext (sLit ", @object")
+      then
+        sdocWithDynFlags $ \df ->
+          text ".type " <> ppr lbl <> ptext (sLit  ", ") <> pprLabelType' df lbl
       else empty
 
 pprLabel :: CLabel -> SDoc
 pprLabel lbl = pprGloblDecl lbl
-            $$ pprTypeAndSizeDecl lbl
+            $$ pprTypeDecl lbl
             $$ (ppr lbl <> char ':')
 
+{-
+Note [Pretty print ASCII when AsmCodeGen]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, when generating assembly code, we created SDoc with
+`(ptext . sLit)` for every bytes in literal bytestring, then
+combine them using `hcat`.
+
+When handling literal bytestrings with millions of bytes,
+millions of SDoc would be created and to combine, leading to
+high memory usage.
+
+Now we escape the given bytestring to string directly and construct
+SDoc only once. This improvement could dramatically decrease the
+memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
+string in source code. See Trac #14741 for profiling results.
+-}
 
 pprASCII :: [Word8] -> SDoc
 pprASCII str
-  = hcat (map (do1 . fromIntegral) str)
+  -- Transform this given literal bytestring to escaped string and construct
+  -- the literal SDoc directly.
+  -- See Trac #14741
+  -- and Note [Pretty print ASCII when AsmCodeGen]
+  = ptext $ sLit $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" str
     where
-       do1 :: Int -> SDoc
-       do1 w | '\t' <- chr w = ptext (sLit "\\t")
-       do1 w | '\n' <- chr w = ptext (sLit "\\n")
-       do1 w | '"'  <- chr w = ptext (sLit "\\\"")
-       do1 w | '\\' <- chr w = ptext (sLit "\\\\")
-       do1 w | isPrint (chr w) = char (chr w)
-       do1 w | otherwise = char '\\' <> octal w
-
-       octal :: Int -> SDoc
-       octal w = int ((w `div` 64) `mod` 8)
-                  <> int ((w `div` 8) `mod` 8)
-                  <> int (w `mod` 8)
+       do1 :: Int -> String
+       do1 w | '\t' <- chr w = "\\t"
+             | '\n' <- chr w = "\\n"
+             | '"'  <- chr w = "\\\""
+             | '\\' <- chr w = "\\\\"
+             | isPrint (chr w) = [chr w]
+             | otherwise = '\\' : octal w
+
+       octal :: Int -> String
+       octal w = [ chr (ord '0' + (w `div` 64) `mod` 8)
+                 , chr (ord '0' + (w `div` 8) `mod` 8)
+                 , chr (ord '0' + w `mod` 8)
+                 ]
 
 pprAlign :: Int -> SDoc
 pprAlign bytes
@@ -505,7 +596,7 @@ pprDataItem' dflags lit
                   --
                   case lit of
                   -- A relative relocation:
-                  CmmLabelDiffOff _ _ _ ->
+                  CmmLabelDiffOff _ _ _ _ ->
                       [text "\t.long\t" <> pprImm imm,
                        text "\t.long\t0"]
                   _ ->
@@ -516,7 +607,7 @@ pprDataItem' dflags lit
 
 
 asmComment :: SDoc -> SDoc
-asmComment c = ifPprDebug $ text "# " <> c
+asmComment c = whenPprDebug $ text "# " <> c
 
 pprInstr :: Instr -> SDoc
 
@@ -645,6 +736,9 @@ pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst
 pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)
 pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)
 
+pprInstr (PDEP format src mask dst)   = pprFormatOpOpReg (sLit "pdep") format src mask dst
+pprInstr (PEXT format src mask dst)   = pprFormatOpOpReg (sLit "pext") format src mask dst
+
 pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src
 pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src
 pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src
@@ -702,7 +796,7 @@ pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
 
 pprInstr (JXX cond blockid)
   = pprCondInstr (sLit "j") cond (ppr lab)
-  where lab = mkAsmTempLabel (getUnique blockid)
+  where lab = blockLbl blockid
 
 pprInstr        (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
 
@@ -1259,6 +1353,16 @@ pprFormatRegRegReg name format reg1 reg2 reg3
         pprReg format reg3
     ]
 
+pprFormatOpOpReg :: LitString -> Format -> Operand -> Operand -> Reg -> SDoc
+pprFormatOpOpReg name format op1 op2 reg3
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2,
+        comma,
+        pprReg format reg3
+    ]
 
 pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc
 pprFormatAddrReg name format op dst
@@ -1302,4 +1406,3 @@ pprFormatOpOpCoerce name format1 format2 op1 op2
 pprCondInstr :: LitString -> Cond -> SDoc -> SDoc
 pprCondInstr name cond arg
   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
-
diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
index 4dfe0350d4..226441b16f 100644
--- a/compiler/nativeGen/X86/RegInfo.hs
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -9,6 +9,8 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Format
 import Reg
 
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 4cb82ea224..97c3b984e2 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -48,6 +48,8 @@ where
 #include "nativeGen/NCG.h"
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CodeGen.Platform
 import Reg
 import RegClass
@@ -58,8 +60,10 @@ import DynFlags
 import Outputable
 import Platform
 
+import qualified Data.Array as A
+
 -- | regSqueeze_class reg
---      Calculuate the maximum number of register colors that could be
+--      Calculate the maximum number of register colors that could be
 --      denied to a node of this class due to having this reg
 --      as a neighbour.
 --
@@ -142,7 +146,7 @@ litToImm (CmmFloat f W32)    = ImmFloat f
 litToImm (CmmFloat f W64)    = ImmDouble f
 litToImm (CmmLabel l)        = ImmCLbl l
 litToImm (CmmLabelOff l off) = ImmIndex l off
-litToImm (CmmLabelDiffOff l1 l2 off)
+litToImm (CmmLabelDiffOff l1 l2 off _)
                              = ImmConstantSum
                                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
                                (ImmInt off)
@@ -234,7 +238,6 @@ xmmregnos platform = [firstxmm  .. lastxmm platform]
 floatregnos :: Platform -> [RegNo]
 floatregnos platform = fakeregnos ++ xmmregnos platform
 
-
 -- argRegs is the set of regs which are read for an n-argument call to C.
 -- For archs which pass all args on the stack (x86), is empty.
 -- Sparc passes up to the first 6 args in regs.
@@ -267,13 +270,13 @@ showReg platform n
         | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)
         | n >= firstfake = "%fake" ++ show (n-firstfake)
         | n >= 8         = "%r" ++ show n
-        | otherwise      = regNames platform !! n
+        | otherwise      = regNames platform A.! n
 
-regNames :: Platform -> [String]
+regNames :: Platform -> A.Array Int String
 regNames platform
     = if target32Bit platform
-      then ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
-      else ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]
+      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
+      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]
 
 
 
@@ -404,7 +407,10 @@ callClobberedRegs platform
  | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
  | platformOS platform == OSMinGW32
    = [rax,rcx,rdx,r8,r9,r10,r11]
-   ++ map regSingle (floatregnos platform)
+   -- Only xmm0-5 are caller-saves registers on 64bit windows.
+   -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )
+   -- For details check the Win64 ABI.
+   ++ map regSingle fakeregnos ++ map xmm [0  .. 5]
  | otherwise
     -- all xmm regs are caller-saves
     -- caller-saves registers
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index 34787b3399..6ae01d6fe0 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -13,6 +13,8 @@ module ApiAnnotation (
   LRdrName -- Exists for haddocks only
   ) where
 
+import GhcPrelude
+
 import RdrName
 import Outputable
 import SrcLoc
@@ -278,13 +280,13 @@ data AnnKeywordId
     | AnnThIdTySplice -- ^ '$$'
     | AnnThTyQuote -- ^ double '''
     | AnnTilde -- ^ '~'
-    | AnnTildehsh -- ^ '~#'
     | AnnType
     | AnnUnit -- ^ '()' for types
     | AnnUsing
     | AnnVal  -- ^ e.g. INTEGER
     | AnnValStr  -- ^ String value, will need quotes when output
     | AnnVbar -- ^ '|'
+    | AnnVia -- ^ 'via'
     | AnnWhere
     | Annlarrowtail -- ^ '-<'
     | AnnlarrowtailU -- ^ '-<', unicode variant
@@ -320,7 +322,7 @@ instance Outputable AnnotationComment where
 
 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
 --             'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma',
---             'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnTildehsh',
+--             'ApiAnnotation.AnnRarrow'
 --             'ApiAnnotation.AnnTilde'
 --   - May have 'ApiAnnotation.AnnComma' when in a list
 type LRdrName = Located RdrName
diff --git a/compiler/parser/Ctype.hs b/compiler/parser/Ctype.hs
index 6423218f91..9c3988e869 100644
--- a/compiler/parser/Ctype.hs
+++ b/compiler/parser/Ctype.hs
@@ -16,6 +16,8 @@ module Ctype
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Data.Int         ( Int32 )
 import Data.Bits        ( Bits((.&.)) )
 import Data.Char        ( ord, chr )
diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
index 387cbf8f08..7969f6e1a2 100644
--- a/compiler/parser/HaddockUtils.hs
+++ b/compiler/parser/HaddockUtils.hs
@@ -1,6 +1,8 @@
 
 module HaddockUtils where
 
+import GhcPrelude
+
 import HsSyn
 import SrcLoc
 
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 936948b40f..bceb48bf48 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -68,6 +68,7 @@ module Lexer (
    explicitNamespacesEnabled,
    patternSynonymsEnabled,
    sccProfilingOn, hpcEnabled,
+   starIsTypeEnabled,
    addWarning,
    lexTokenStream,
    addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn,
@@ -75,11 +76,11 @@ module Lexer (
    moveAnnotations
   ) where
 
+import GhcPrelude
+
 -- base
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
-import Control.Monad.Fail
-#endif
+import Control.Monad.Fail as MonadFail
 import Data.Bits
 import Data.Char
 import Data.List
@@ -105,7 +106,7 @@ import Outputable
 import StringBuffer
 import FastString
 import UniqFM
-import Util             ( readRational )
+import Util             ( readRational, readHexRational )
 
 -- compiler/main
 import ErrUtils
@@ -129,38 +130,38 @@ import ApiAnnotation
 
 -- NB: The logic behind these definitions is also reflected in basicTypes/Lexeme.hs
 -- Any changes here should likely be reflected there.
-$unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetByte.
+$unispace    = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $nl          = [\n\r\f]
 $whitechar   = [$nl\v\ $unispace]
 $white_no_nl = $whitechar # \n -- TODO #8424
 $tab         = \t
 
 $ascdigit  = 0-9
-$unidigit  = \x03 -- Trick Alex into handling Unicode. See alexGetByte.
+$unidigit  = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
 $digit     = [$ascdigit $unidigit]
 
 $special   = [\(\)\,\;\[\]\`\{\}]
 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
-$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetByte.
+$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $symbol    = [$ascsymbol $unisymbol] # [$special \_\"\']
 
-$unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetByte.
+$unilarge  = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $asclarge  = [A-Z]
 $large     = [$asclarge $unilarge]
 
-$unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetByte.
+$unismall  = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $ascsmall  = [a-z]
 $small     = [$ascsmall $unismall \_]
 
-$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetByte.
+$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $graphic   = [$small $large $symbol $digit $special $unigraphic \"\']
 
 $binit     = 0-1
 $octit     = 0-7
 $hexit     = [$decdigit A-F a-f]
 
-$uniidchar = \x07 -- Trick Alex into handling Unicode. See alexGetByte.
+$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex].
 $idchar    = [$small $large $digit $uniidchar \']
 
 $pragmachar = [$small $large $digit]
@@ -177,11 +178,14 @@ $docsym    = [\| \^ \* \$]
 @varsym    = ($symbol # \:) $symbol*  -- variable (operator) symbol
 @consym    = \: $symbol*              -- constructor (operator) symbol
 
-@decimal     = $decdigit+
-@binary      = $binit+
-@octal       = $octit+
-@hexadecimal = $hexit+
-@exponent    = [eE] [\-\+]? @decimal
+-- See Note [Lexing NumericUnderscores extension] and #14473
+@numspc       = _*                   -- numeric spacer (#14473)
+@decimal      = $decdigit(@numspc $decdigit)*
+@binary       = $binit(@numspc $binit)*
+@octal        = $octit(@numspc $octit)*
+@hexadecimal  = $hexit(@numspc $hexit)*
+@exponent     = @numspc [eE] [\-\+]? @decimal
+@bin_exponent = @numspc [pP] [\-\+]? @decimal
 
 @qual = (@conid \.)+
 @qvarid = @qual @varid
@@ -189,7 +193,8 @@ $docsym    = [\| \^ \* \$]
 @qvarsym = @qual @varsym
 @qconsym = @qual @consym
 
-@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent
+@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent
 
 -- normal signed numerical literals can only be explicitly negative,
 -- not explicitly positive (contrast @exponent)
@@ -307,15 +312,18 @@ $tab          { warnTab }
 
 -- single-line line pragmas, of the form
 --    # <line> "<file>" <extra-stuff> \n
-<line_prag1> @decimal                   { setLine line_prag1a }
-<line_prag1a> \" [$graphic \ ]* \"      { setFile line_prag1b }
-<line_prag1b> .*                        { pop }
+<line_prag1> {
+  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag1a }
+  ()                                           { failLinePrag1 }
+}
+<line_prag1a> .*                               { popLinePrag1 }
 
 -- Haskell-style line pragmas, of the form
 --    {-# LINE <line> "<file>" #-}
-<line_prag2> @decimal                   { setLine line_prag2a }
-<line_prag2a> \" [$graphic \ ]* \"      { setFile line_prag2b }
-<line_prag2b> "#-}"|"-}"                { pop }
+<line_prag2> {
+  @decimal $white_no_nl+ \" [$graphic \ ]* \"  { setLineAndFile line_prag2a }
+}
+<line_prag2a> "#-}"|"-}"                       { pop }
    -- NOTE: accept -} at the end of a LINE pragma, for compatibility
    -- with older versions of GHC which generated these.
 
@@ -367,11 +375,6 @@ $tab          { warnTab }
 -- "special" symbols
 
 <0> {
-  "[:" / { ifExtension parrEnabled }    { token ITopabrack }
-  ":]" / { ifExtension parrEnabled }    { token ITcpabrack }
-}
-
-<0> {
   "[|"        / { ifExtension thQuotesEnabled } { token (ITopenExpQuote NoE
                                                                 NormalSyntax) }
   "[||"       / { ifExtension thQuotesEnabled } { token (ITopenTExpQuote NoE) }
@@ -483,21 +486,34 @@ $tab          { warnTab }
 
 -- For the normal boxed literals we need to be careful
 -- when trying to be close to Haskell98
+
+-- Note [Lexing NumericUnderscores extension] (#14473)
+--
+-- NumericUnderscores extension allows underscores in numeric literals.
+-- Multiple underscores are represented with @numspc macro.
+-- To be simpler, we have only the definitions with underscores.
+-- And then we have a separate function (tok_integral and tok_frac)
+-- that validates the literals.
+-- If extensions are not enabled, check that there are no underscores.
+--
 <0> {
   -- Normal integral literals (:: Num a => a, from Integer)
   @decimal                                                               { tok_num positive 0 0 decimal }
-  0[bB] @binary                / { ifExtension binaryLiteralsEnabled }   { tok_num positive 2 2 binary }
-  0[oO] @octal                                                           { tok_num positive 2 2 octal }
-  0[xX] @hexadecimal                                                     { tok_num positive 2 2 hexadecimal }
+  0[bB] @numspc @binary        / { ifExtension binaryLiteralsEnabled }   { tok_num positive 2 2 binary }
+  0[oO] @numspc @octal                                                   { tok_num positive 2 2 octal }
+  0[xX] @numspc @hexadecimal                                             { tok_num positive 2 2 hexadecimal }
   @negative @decimal           / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal }
-  @negative 0[bB] @binary      / { ifExtension negativeLiteralsEnabled `alexAndPred`
-                                   ifExtension binaryLiteralsEnabled }   { tok_num negative 3 3 binary }
-  @negative 0[oO] @octal       / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
-  @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
+  @negative 0[bB] @numspc @binary  / { ifExtension negativeLiteralsEnabled `alexAndPred`
+                                       ifExtension binaryLiteralsEnabled }   { tok_num negative 3 3 binary }
+  @negative 0[oO] @numspc @octal   / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal }
+  @negative 0[xX] @numspc @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal }
 
   -- Normal rational literals (:: Fractional a => a, from Rational)
-  @floating_point                                                        { strtoken tok_float }
-  @negative @floating_point    / { ifExtension negativeLiteralsEnabled } { strtoken tok_float }
+  @floating_point                                                        { tok_frac 0 tok_float }
+  @negative @floating_point    / { ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_float }
+  0[xX] @numspc @hex_floating_point     / { ifExtension hexFloatLiteralsEnabled } { tok_frac 0 tok_hex_float }
+  @negative 0[xX] @numspc @hex_floating_point / { ifExtension hexFloatLiteralsEnabled `alexAndPred`
+                                                  ifExtension negativeLiteralsEnabled } { tok_frac 0 tok_hex_float }
 }
 
 <0> {
@@ -505,26 +521,26 @@ $tab          { warnTab }
   -- It's simpler (and faster?) to give separate cases to the negatives,
   -- especially considering octal/hexadecimal prefixes.
   @decimal                     \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
-  0[bB] @binary                \# / { ifExtension magicHashEnabled `alexAndPred`
+  0[bB] @numspc @binary        \# / { ifExtension magicHashEnabled `alexAndPred`
                                       ifExtension binaryLiteralsEnabled } { tok_primint positive 2 3 binary }
-  0[oO] @octal                 \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
-  0[xX] @hexadecimal           \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
+  0[oO] @numspc @octal         \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
+  0[xX] @numspc @hexadecimal   \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
   @negative @decimal           \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
-  @negative 0[bB] @binary      \# / { ifExtension magicHashEnabled `alexAndPred`
-                                      ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
-  @negative 0[oO] @octal       \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
-  @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
+  @negative 0[bB] @numspc @binary  \# / { ifExtension magicHashEnabled `alexAndPred`
+                                          ifExtension binaryLiteralsEnabled } { tok_primint negative 3 4 binary }
+  @negative 0[oO] @numspc @octal   \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
+  @negative 0[xX] @numspc @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
 
   @decimal                     \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
-  0[bB] @binary                \# \# / { ifExtension magicHashEnabled `alexAndPred`
+  0[bB] @numspc @binary        \# \# / { ifExtension magicHashEnabled `alexAndPred`
                                          ifExtension binaryLiteralsEnabled } { tok_primword 2 4 binary }
-  0[oO] @octal                 \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
-  0[xX] @hexadecimal           \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
+  0[oO] @numspc @octal         \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
+  0[xX] @numspc @hexadecimal   \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
 
   -- Unboxed floats and doubles (:: Float#, :: Double#)
   -- prim_{float,double} work with signed literals
-  @signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
-  @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
+  @signed @floating_point \# / { ifExtension magicHashEnabled } { tok_frac 1 tok_primfloat }
+  @signed @floating_point \# \# / { ifExtension magicHashEnabled } { tok_frac 2 tok_primdouble }
 }
 
 -- Strings and chars are lexed by hand-written code.  The reason is
@@ -620,6 +636,7 @@ data Token
   | ITstatic
   | ITstock
   | ITanyclass
+  | ITvia
 
   -- Backpack tokens
   | ITunit
@@ -635,7 +652,8 @@ data Token
   | ITrules_prag        SourceText
   | ITwarning_prag      SourceText
   | ITdeprecated_prag   SourceText
-  | ITline_prag
+  | ITline_prag         SourceText  -- not usually produced, see 'use_pos_prags'
+  | ITcolumn_prag       SourceText  -- not usually produced, see 'use_pos_prags'
   | ITscc_prag          SourceText
   | ITgenerated_prag    SourceText
   | ITcore_prag         SourceText         -- hdaume: core annotations
@@ -647,15 +665,13 @@ data Token
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
-  | ITvect_prag         SourceText
-  | ITvect_scalar_prag  SourceText
-  | ITnovect_prag       SourceText
   | ITminimal_prag      SourceText
   | IToverlappable_prag SourceText  -- instance overlap mode
   | IToverlapping_prag  SourceText  -- instance overlap mode
   | IToverlaps_prag     SourceText  -- instance overlap mode
   | ITincoherent_prag   SourceText  -- instance overlap mode
   | ITctype             SourceText
+  | ITcomment_line_prag         -- See Note [Nested comment line pragmas]
 
   | ITdotdot                    -- reserved symbols
   | ITcolon
@@ -668,10 +684,10 @@ data Token
   | ITrarrow            IsUnicodeSyntax
   | ITat
   | ITtilde
-  | ITtildehsh
   | ITdarrow            IsUnicodeSyntax
   | ITminus
   | ITbang
+  | ITstar              IsUnicodeSyntax
   | ITdot
 
   | ITbiglam                    -- GHC-extension symbols
@@ -820,6 +836,7 @@ reservedWordsFM = listToUFM $
          ( "static",         ITstatic,        0 ),
          ( "stock",          ITstock,         0 ),
          ( "anyclass",       ITanyclass,      0 ),
+         ( "via",            ITvia,           0 ),
          ( "group",          ITgroup,         xbit TransformComprehensionsBit),
          ( "by",             ITby,            xbit TransformComprehensionsBit),
          ( "using",          ITusing,         xbit TransformComprehensionsBit),
@@ -878,11 +895,12 @@ reservedSymsFM = listToUFM $
        ,("->",  ITrarrow NormalSyntax, always)
        ,("@",   ITat,                  always)
        ,("~",   ITtilde,               always)
-       ,("~#",  ITtildehsh,            magicHashEnabled)
        ,("=>",  ITdarrow NormalSyntax, always)
        ,("-",   ITminus,               always)
        ,("!",   ITbang,                always)
 
+       ,("*", ITstar NormalSyntax, starIsTypeEnabled)
+
         -- For 'forall a . t'
        ,(".", ITdot,  always) -- \i -> explicitForallEnabled i || inRulePrag i)
 
@@ -905,6 +923,8 @@ reservedSymsFM = listToUFM $
                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
        ,("⤜",   ITRarrowtail UnicodeSyntax,
                                 \i -> unicodeSyntaxEnabled i && arrowsEnabled i)
+       ,("★",   ITstar UnicodeSyntax,
+                  \i -> unicodeSyntaxEnabled i && starIsTypeEnabled i)
 
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
@@ -938,17 +958,26 @@ strtoken :: (String -> Token) -> Action
 strtoken f span buf len =
   return (L span $! (f $! lexemeToString buf len))
 
-init_strtoken :: Int -> (String -> Token) -> Action
--- like strtoken, but drops the last N character(s)
-init_strtoken drop f span buf len =
-  return (L span $! (f $! lexemeToString buf (len-drop)))
-
 begin :: Int -> Action
 begin code _span _str _len = do pushLexState code; lexToken
 
 pop :: Action
 pop _span _buf _len = do _ <- popLexState
                          lexToken
+-- See Note [Nested comment line pragmas]
+failLinePrag1 :: Action
+failLinePrag1 span _buf _len = do
+  b <- extension inNestedComment
+  if b then return (L span ITcomment_line_prag)
+       else lexError "lexical error in pragma"
+
+-- See Note [Nested comment line pragmas]
+popLinePrag1 :: Action
+popLinePrag1 span _buf _len = do
+  b <- extension inNestedComment
+  if b then return (L span ITcomment_line_prag) else do
+    _ <- popLexState
+    lexToken
 
 hopefully_open_brace :: Action
 hopefully_open_brace span buf len
@@ -1088,6 +1117,12 @@ nested_comment cont span buf len = do
         Nothing  -> errBrace input span
         Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input
         Just (_,_)       -> go ('\123':commentAcc) n input
+      -- See Note [Nested comment line pragmas]
+      Just ('\n',input) -> case alexGetChar' input of
+        Nothing  -> errBrace input span
+        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
+                           go (parsedAcc ++ '\n':commentAcc) n input
+        Just (_,_)   -> go ('\n':commentAcc) n input
       Just (c,input) -> go (c:commentAcc) n input
 
 nested_doc_comment :: Action
@@ -1107,8 +1142,60 @@ nested_doc_comment span buf _len = withLexedDocType (go "")
           let cont = do input <- getInput; go commentAcc input docType False
           nested_comment cont span buf _len
         Just (_,_) -> go ('\123':commentAcc) input docType False
+      -- See Note [Nested comment line pragmas]
+      Just ('\n',input) -> case alexGetChar' input of
+        Nothing  -> errBrace input span
+        Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input
+                           go (parsedAcc ++ '\n':commentAcc) input docType False
+        Just (_,_)   -> go ('\n':commentAcc) input docType False
       Just (c,input) -> go (c:commentAcc) input docType False
 
+-- See Note [Nested comment line pragmas]
+parseNestedPragma :: AlexInput -> P (String,AlexInput)
+parseNestedPragma input@(AI _ buf) = do
+  origInput <- getInput
+  setInput input
+  setExts (.|. xbit InNestedCommentBit)
+  pushLexState bol
+  lt <- lexToken
+  _ <- popLexState
+  setExts (.&. complement (xbit InNestedCommentBit))
+  postInput@(AI _ postBuf) <- getInput
+  setInput origInput
+  case unLoc lt of
+    ITcomment_line_prag -> do
+      let bytes = byteDiff buf postBuf
+          diff  = lexemeToString buf bytes
+      return (reverse diff, postInput)
+    lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt'))
+
+{-
+Note [Nested comment line pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to ignore cpp-preprocessor-generated #line pragmas if they were inside
+nested comments.
+
+Now, when parsing a nested comment, if we encounter a line starting with '#' we
+call parseNestedPragma, which executes the following:
+1. Save the current lexer input (loc, buf) for later
+2. Set the current lexer input to the beginning of the line starting with '#'
+3. Turn the 'InNestedComment' extension on
+4. Push the 'bol' lexer state
+5. Lex a token. Due to (2), (3), and (4), this should always lex a single line
+   or less and return the ITcomment_line_prag token. This may set source line
+   and file location if a #line pragma is successfully parsed
+6. Restore lexer input and state to what they were before we did all this
+7. Return control to the function parsing a nested comment, informing it of
+   what the lexer parsed
+
+Regarding (5) above:
+Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1)
+checks if the 'InNestedComment' extension is set. If it is, that function will
+return control to parseNestedPragma by returning the ITcomment_line_prag token.
+
+See #314 for more background on the bug this fixes.
+-}
+
 withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
                  -> P (RealLocated Token)
 withLexedDocType lexDocComment = do
@@ -1135,6 +1222,27 @@ rulePrag span buf len = do
   let !src = lexemeToString buf len
   return (L span (ITrules_prag (SourceText src)))
 
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
+-- of updating the position in 'PState'
+linePrag :: Action
+linePrag span buf len = do
+  ps <- getPState
+  if use_pos_prags ps
+    then begin line_prag2 span buf len
+    else let !src = lexemeToString buf len
+         in return (L span (ITline_prag (SourceText src)))
+
+-- When 'use_pos_prags' is not set, it is expected that we emit a token instead
+-- of updating the position in 'PState'
+columnPrag :: Action
+columnPrag span buf len = do
+  ps <- getPState
+  let !src = lexemeToString buf len
+  if use_pos_prags ps
+    then begin column_prag span buf len
+    else let !src = lexemeToString buf len
+         in return (L span (ITcolumn_prag (SourceText src)))
+
 endPrag :: Action
 endPrag span _buf _len = do
   setExts (.&. complement (xbit InRulePragBit))
@@ -1210,15 +1318,14 @@ varid :: Action
 varid span buf len =
   case lookupUFM reservedWordsFM fs of
     Just (ITcase, _) -> do
-      lambdaCase <- extension lambdaCaseEnabled
-      keyword <- if lambdaCase
-                 then do
-                   lastTk <- getLastTk
-                   return $ case lastTk of
-                     Just ITlam -> ITlcase
-                     _          -> ITcase
-                 else
-                   return ITcase
+      lastTk <- getLastTk
+      keyword <- case lastTk of
+        Just ITlam -> do
+          lambdaCase <- extension lambdaCaseEnabled
+          if lambdaCase
+            then return ITlcase
+            else failMsgP "Illegal lambda-case (use -XLambdaCase)"
+        _ -> return ITcase
       maybe_layout keyword
       return $ L span keyword
     Just (ITstatic, _) -> do
@@ -1272,8 +1379,12 @@ tok_integral :: (SourceText -> Integer -> Token)
              -> Int -> Int
              -> (Integer, (Char -> Int))
              -> Action
-tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
- = return $ L span $ itint (SourceText $ lexemeToString buf len)
+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do
+  numericUnderscores <- extension numericUnderscoresEnabled  -- #14473
+  let src = lexemeToString buf len
+  if (not numericUnderscores) && ('_' `elem` src)
+    then failMsgP "Use NumericUnderscores to allow underscores in integer literals"
+    else return $ L span $ itint (SourceText src)
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 
@@ -1305,15 +1416,32 @@ octal = (8,octDecDigit)
 hexadecimal = (16,hexDigit)
 
 -- readRational can understand negative rationals, exponents, everything.
+tok_frac :: Int -> (String -> Token) -> Action
+tok_frac drop f span buf len = do
+  numericUnderscores <- extension numericUnderscoresEnabled  -- #14473
+  let src = lexemeToString buf (len-drop)
+  if (not numericUnderscores) && ('_' `elem` src)
+    then failMsgP "Use NumericUnderscores to allow underscores in floating literals"
+    else return (L span $! (f $! src))
+
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float      str  = ITrational   $! readFractionalLit str
-tok_primfloat  str  = ITprimfloat  $! readFractionalLit str
-tok_primdouble str  = ITprimdouble $! readFractionalLit str
+tok_float        str = ITrational   $! readFractionalLit str
+tok_hex_float    str = ITrational   $! readHexFractionalLit str
+tok_primfloat    str = ITprimfloat  $! readFractionalLit str
+tok_primdouble   str = ITprimdouble $! readFractionalLit str
 
 readFractionalLit :: String -> FractionalLit
 readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
                         where is_neg = case str of ('-':_) -> True
                                                    _       -> False
+readHexFractionalLit :: String -> FractionalLit
+readHexFractionalLit str =
+  FL { fl_text  = SourceText str
+     , fl_neg   = case str of
+                    '-' : _ -> True
+                    _       -> False
+     , fl_value = readHexRational str
+     }
 
 -- -----------------------------------------------------------------------------
 -- Layout processing
@@ -1321,20 +1449,23 @@ readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str
 -- we're at the first token on a line, insert layout tokens if necessary
 do_bol :: Action
 do_bol span _str _len = do
-        (pos, gen_semic) <- getOffside
-        case pos of
-            LT -> do
-                --trace "layout: inserting '}'" $ do
-                popContext
-                -- do NOT pop the lex state, we might have a ';' to insert
-                return (L span ITvccurly)
-            EQ | gen_semic -> do
-                --trace "layout: inserting ';'" $ do
-                _ <- popLexState
-                return (L span ITsemi)
-            _ -> do
-                _ <- popLexState
-                lexToken
+        -- See Note [Nested comment line pragmas]
+        b <- extension inNestedComment
+        if b then return (L span ITcomment_line_prag) else do
+          (pos, gen_semic) <- getOffside
+          case pos of
+              LT -> do
+                  --trace "layout: inserting '}'" $ do
+                  popContext
+                  -- do NOT pop the lex state, we might have a ';' to insert
+                  return (L span ITvccurly)
+              EQ | gen_semic -> do
+                  --trace "layout: inserting ';'" $ do
+                  _ <- popLexState
+                  return (L span ITsemi)
+              _ -> do
+                  _ <- popLexState
+                  lexToken
 
 -- certain keywords put us in the "layout" state, where we might
 -- add an opening curly brace.
@@ -1394,29 +1525,13 @@ do_layout_left span _buf _len = do
 -- -----------------------------------------------------------------------------
 -- LINE pragmas
 
-setLine :: Int -> Action
-setLine code span buf len = do
-  let line = parseUnsignedInteger buf len 10 octDecDigit
-  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-        -- subtract one: the line number refers to the *following* line
-  _ <- popLexState
-  pushLexState code
-  lexToken
-
-setColumn :: Action
-setColumn span buf len = do
-  let column =
-        case reads (lexemeToString buf len) of
-          [(column, _)] -> column
-          _ -> error "setColumn: expected integer" -- shouldn't happen
-  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)
-                          (fromIntegral (column :: Integer)))
-  _ <- popLexState
-  lexToken
-
-setFile :: Int -> Action
-setFile code span buf len = do
-  let file = mkFastString (go (lexemeToString (stepOn buf) (len-2)))
+setLineAndFile :: Int -> Action
+setLineAndFile code span buf len = do
+  let src = lexemeToString buf (len - 1)  -- drop trailing quotation mark
+      linenumLen = length $ head $ words src
+      linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit
+      file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src
+          -- skip everything through first quotation mark to get to the filename
         where go ('\\':c:cs) = c : go cs
               go (c:cs)      = c : go cs
               go []          = []
@@ -1430,12 +1545,24 @@ setFile code span buf len = do
               -- filenames and it does not remove duplicate
               -- backslashes after the drive letter (should it?).
   setAlrLastLoc $ alrInitialLoc file
-  setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+  setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span))
+      -- subtract one: the line number refers to the *following* line
   addSrcFile file
   _ <- popLexState
   pushLexState code
   lexToken
 
+setColumn :: Action
+setColumn span buf len = do
+  let column =
+        case reads (lexemeToString buf len) of
+          [(column, _)] -> column
+          _ -> error "setColumn: expected integer" -- shouldn't happen
+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span)
+                          (fromIntegral (column :: Integer)))
+  _ <- popLexState
+  lexToken
+
 alrInitialLoc :: FastString -> RealSrcSpan
 alrInitialLoc file = mkRealSrcSpan loc loc
     where -- This is a hack to ensure that the first line in a file
@@ -1859,6 +1986,10 @@ data PState = PState {
         -- token doesn't need to close anything:
         alr_justClosedExplicitLetBlock :: Bool,
 
+        -- If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}'
+        -- update the 'loc' field. Otherwise, those pragmas are lexed as tokens.
+        use_pos_prags :: Bool,
+
         -- The next three are used to implement Annotations giving the
         -- locations of 'noise' tokens in the source, so that users of
         -- the GHC API can do source to source conversions.
@@ -1892,12 +2023,10 @@ instance Applicative P where
 
 instance Monad P where
   (>>=) = thenP
-  fail = failP
+  fail = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail P where
   fail = failP
-#endif
 
 returnP :: a -> P a
 returnP a = a `seq` (P $ \s -> POk s a)
@@ -1970,27 +2099,29 @@ getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
 
 data AlexInput = AI RealSrcLoc StringBuffer
 
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI _ buf) = prevChar buf '\n'
+{-
+Note [Unicode in Alex]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Although newer versions of Alex support unicode, this grammar is processed with
+the old style '--latin1' behaviour. This means that when implementing the
+functions
 
--- backwards compatibility for Alex 2.x
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar inp = case alexGetByte inp of
-                    Nothing    -> Nothing
-                    Just (b,i) -> c `seq` Just (c,i)
-                       where c = chr $ fromIntegral b
+    alexGetByte       :: AlexInput -> Maybe (Word8,AlexInput)
+    alexInputPrevChar :: AlexInput -> Char
 
-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
-alexGetByte (AI loc s)
-  | atEnd s   = Nothing
-  | otherwise = byte `seq` loc' `seq` s' `seq`
-                --trace (show (ord c)) $
-                Just (byte, (AI loc' s'))
-  where (c,s') = nextChar s
-        loc'   = advanceSrcLoc loc c
-        byte   = fromIntegral $ ord adj_c
+which Alex uses to take apart our 'AlexInput', we must
 
-        non_graphic     = '\x00'
+  * return a latin1 character in the 'Word8' that 'alexGetByte' expects
+  * return a latin1 character in 'alexInputPrevChar'.
+
+We handle this in 'adjustChar' by squishing entire classes of unicode
+characters into single bytes.
+-}
+
+{-# INLINE adjustChar #-}
+adjustChar :: Char -> Word8
+adjustChar c = fromIntegral $ ord adj_c
+  where non_graphic     = '\x00'
         upper           = '\x01'
         lower           = '\x02'
         digit           = '\x03'
@@ -2036,6 +2167,32 @@ alexGetByte (AI loc s)
                   Space                 -> space
                   _other                -> non_graphic
 
+-- Getting the previous 'Char' isn't enough here - we need to convert it into
+-- the same format that 'alexGetByte' would have produced.
+--
+-- See Note [Unicode in Alex] and #13986.
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc))
+  where pc = prevChar buf '\n'
+
+-- backwards compatibility for Alex 2.x
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar inp = case alexGetByte inp of
+                    Nothing    -> Nothing
+                    Just (b,i) -> c `seq` Just (c,i)
+                       where c = chr $ fromIntegral b
+
+-- See Note [Unicode in Alex]
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (AI loc s)
+  | atEnd s   = Nothing
+  | otherwise = byte `seq` loc' `seq` s' `seq`
+                --trace (show (ord c)) $
+                Just (byte, (AI loc' s'))
+  where (c,s') = nextChar s
+        loc'   = advanceSrcLoc loc c
+        byte   = adjustChar c
+
 -- This version does not squash unicode characters, it is used when
 -- lexing strings.
 alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
@@ -2146,7 +2303,6 @@ data ExtBits
   = FfiBit
   | InterruptibleFfiBit
   | CApiFfiBit
-  | ParrBit
   | ArrowsBit
   | ThBit
   | ThQuotesBit
@@ -2166,6 +2322,7 @@ data ExtBits
   | TransformComprehensionsBit
   | QqBit -- enable quasiquoting
   | InRulePragBit
+  | InNestedCommentBit -- See Note [Nested comment line pragmas]
   | RawTokenStreamBit -- producing a token stream with all comments included
   | SccProfilingOnBit
   | HpcBit
@@ -2178,15 +2335,16 @@ data ExtBits
   | LambdaCaseBit
   | BinaryLiteralsBit
   | NegativeLiteralsBit
+  | HexFloatLiteralsBit
   | TypeApplicationsBit
   | StaticPointersBit
+  | NumericUnderscoresBit
+  | StarIsTypeBit
   deriving Enum
 
 
 always :: ExtsBitmap -> Bool
 always           _     = True
-parrEnabled :: ExtsBitmap -> Bool
-parrEnabled = xtest ParrBit
 arrowsEnabled :: ExtsBitmap -> Bool
 arrowsEnabled = xtest ArrowsBit
 thEnabled :: ExtsBitmap -> Bool
@@ -2217,6 +2375,8 @@ qqEnabled :: ExtsBitmap -> Bool
 qqEnabled = xtest QqBit
 inRulePrag :: ExtsBitmap -> Bool
 inRulePrag = xtest InRulePragBit
+inNestedComment :: ExtsBitmap -> Bool
+inNestedComment = xtest InNestedCommentBit
 rawTokenStreamEnabled :: ExtsBitmap -> Bool
 rawTokenStreamEnabled = xtest RawTokenStreamBit
 alternativeLayoutRule :: ExtsBitmap -> Bool
@@ -2240,12 +2400,18 @@ binaryLiteralsEnabled :: ExtsBitmap -> Bool
 binaryLiteralsEnabled = xtest BinaryLiteralsBit
 negativeLiteralsEnabled :: ExtsBitmap -> Bool
 negativeLiteralsEnabled = xtest NegativeLiteralsBit
+hexFloatLiteralsEnabled :: ExtsBitmap -> Bool
+hexFloatLiteralsEnabled = xtest HexFloatLiteralsBit
 patternSynonymsEnabled :: ExtsBitmap -> Bool
 patternSynonymsEnabled = xtest PatternSynonymsBit
 typeApplicationEnabled :: ExtsBitmap -> Bool
 typeApplicationEnabled = xtest TypeApplicationsBit
 staticPointersEnabled :: ExtsBitmap -> Bool
 staticPointersEnabled = xtest StaticPointersBit
+numericUnderscoresEnabled :: ExtsBitmap -> Bool
+numericUnderscoresEnabled = xtest NumericUnderscoresBit
+starIsTypeEnabled :: ExtsBitmap -> Bool
+starIsTypeEnabled = xtest StarIsTypeBit
 
 -- PState for parsing options pragmas
 --
@@ -2264,46 +2430,55 @@ mkParserFlags flags =
     , pExtsBitmap = bitmap
     }
   where
-      bitmap =     FfiBit                      `setBitIf` xopt LangExt.ForeignFunctionInterface flags
-               .|. InterruptibleFfiBit         `setBitIf` xopt LangExt.InterruptibleFFI         flags
-               .|. CApiFfiBit                  `setBitIf` xopt LangExt.CApiFFI                  flags
-               .|. ParrBit                     `setBitIf` xopt LangExt.ParallelArrays           flags
-               .|. ArrowsBit                   `setBitIf` xopt LangExt.Arrows                   flags
-               .|. ThBit                       `setBitIf` xopt LangExt.TemplateHaskell          flags
-               .|. ThQuotesBit                 `setBitIf` xopt LangExt.TemplateHaskellQuotes    flags
-               .|. QqBit                       `setBitIf` xopt LangExt.QuasiQuotes              flags
-               .|. IpBit                       `setBitIf` xopt LangExt.ImplicitParams           flags
-               .|. OverloadedLabelsBit         `setBitIf` xopt LangExt.OverloadedLabels         flags
-               .|. ExplicitForallBit           `setBitIf` xopt LangExt.ExplicitForAll           flags
-               .|. BangPatBit                  `setBitIf` xopt LangExt.BangPatterns             flags
-               .|. HaddockBit                  `setBitIf` gopt Opt_Haddock                      flags
-               .|. MagicHashBit                `setBitIf` xopt LangExt.MagicHash                flags
-               .|. RecursiveDoBit              `setBitIf` xopt LangExt.RecursiveDo              flags
-               .|. UnicodeSyntaxBit            `setBitIf` xopt LangExt.UnicodeSyntax            flags
-               .|. UnboxedTuplesBit            `setBitIf` xopt LangExt.UnboxedTuples            flags
-               .|. UnboxedSumsBit              `setBitIf` xopt LangExt.UnboxedSums              flags
-               .|. DatatypeContextsBit         `setBitIf` xopt LangExt.DatatypeContexts         flags
-               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.TransformListComp        flags
-               .|. TransformComprehensionsBit  `setBitIf` xopt LangExt.MonadComprehensions      flags
-               .|. RawTokenStreamBit           `setBitIf` gopt Opt_KeepRawTokenStream           flags
-               .|. HpcBit                      `setBitIf` gopt Opt_Hpc                          flags
-               .|. AlternativeLayoutRuleBit    `setBitIf` xopt LangExt.AlternativeLayoutRule    flags
-               .|. RelaxedLayoutBit            `setBitIf` xopt LangExt.RelaxedLayout            flags
-               .|. SccProfilingOnBit           `setBitIf` gopt Opt_SccProfilingOn               flags
-               .|. NondecreasingIndentationBit `setBitIf` xopt LangExt.NondecreasingIndentation flags
-               .|. SafeHaskellBit              `setBitIf` safeImportsOn                         flags
-               .|. TraditionalRecordSyntaxBit  `setBitIf` xopt LangExt.TraditionalRecordSyntax  flags
-               .|. ExplicitNamespacesBit       `setBitIf` xopt LangExt.ExplicitNamespaces flags
-               .|. LambdaCaseBit               `setBitIf` xopt LangExt.LambdaCase               flags
-               .|. BinaryLiteralsBit           `setBitIf` xopt LangExt.BinaryLiterals           flags
-               .|. NegativeLiteralsBit         `setBitIf` xopt LangExt.NegativeLiterals         flags
-               .|. PatternSynonymsBit          `setBitIf` xopt LangExt.PatternSynonyms          flags
-               .|. TypeApplicationsBit         `setBitIf` xopt LangExt.TypeApplications         flags
-               .|. StaticPointersBit           `setBitIf` xopt LangExt.StaticPointers           flags
-
-      setBitIf :: ExtBits -> Bool -> ExtsBitmap
-      b `setBitIf` cond | cond      = xbit b
-                        | otherwise = 0
+    bitmap = safeHaskellBit .|. langExtBits .|. optBits
+    safeHaskellBit =
+          SafeHaskellBit `setBitIf` safeImportsOn flags
+    langExtBits =
+          FfiBit                      `xoptBit` LangExt.ForeignFunctionInterface
+      .|. InterruptibleFfiBit         `xoptBit` LangExt.InterruptibleFFI
+      .|. CApiFfiBit                  `xoptBit` LangExt.CApiFFI
+      .|. ArrowsBit                   `xoptBit` LangExt.Arrows
+      .|. ThBit                       `xoptBit` LangExt.TemplateHaskell
+      .|. ThQuotesBit                 `xoptBit` LangExt.TemplateHaskellQuotes
+      .|. QqBit                       `xoptBit` LangExt.QuasiQuotes
+      .|. IpBit                       `xoptBit` LangExt.ImplicitParams
+      .|. OverloadedLabelsBit         `xoptBit` LangExt.OverloadedLabels
+      .|. ExplicitForallBit           `xoptBit` LangExt.ExplicitForAll
+      .|. BangPatBit                  `xoptBit` LangExt.BangPatterns
+      .|. MagicHashBit                `xoptBit` LangExt.MagicHash
+      .|. RecursiveDoBit              `xoptBit` LangExt.RecursiveDo
+      .|. UnicodeSyntaxBit            `xoptBit` LangExt.UnicodeSyntax
+      .|. UnboxedTuplesBit            `xoptBit` LangExt.UnboxedTuples
+      .|. UnboxedSumsBit              `xoptBit` LangExt.UnboxedSums
+      .|. DatatypeContextsBit         `xoptBit` LangExt.DatatypeContexts
+      .|. TransformComprehensionsBit  `xoptBit` LangExt.TransformListComp
+      .|. TransformComprehensionsBit  `xoptBit` LangExt.MonadComprehensions
+      .|. AlternativeLayoutRuleBit    `xoptBit` LangExt.AlternativeLayoutRule
+      .|. RelaxedLayoutBit            `xoptBit` LangExt.RelaxedLayout
+      .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation
+      .|. TraditionalRecordSyntaxBit  `xoptBit` LangExt.TraditionalRecordSyntax
+      .|. ExplicitNamespacesBit       `xoptBit` LangExt.ExplicitNamespaces
+      .|. LambdaCaseBit               `xoptBit` LangExt.LambdaCase
+      .|. BinaryLiteralsBit           `xoptBit` LangExt.BinaryLiterals
+      .|. NegativeLiteralsBit         `xoptBit` LangExt.NegativeLiterals
+      .|. HexFloatLiteralsBit         `xoptBit` LangExt.HexFloatLiterals
+      .|. PatternSynonymsBit          `xoptBit` LangExt.PatternSynonyms
+      .|. TypeApplicationsBit         `xoptBit` LangExt.TypeApplications
+      .|. StaticPointersBit           `xoptBit` LangExt.StaticPointers
+      .|. NumericUnderscoresBit       `xoptBit` LangExt.NumericUnderscores
+      .|. StarIsTypeBit               `xoptBit` LangExt.StarIsType
+    optBits =
+          HaddockBit        `goptBit` Opt_Haddock
+      .|. RawTokenStreamBit `goptBit` Opt_KeepRawTokenStream
+      .|. HpcBit            `goptBit` Opt_Hpc
+      .|. SccProfilingOnBit `goptBit` Opt_SccProfilingOn
+
+    xoptBit bit ext = bit `setBitIf` xopt ext flags
+    goptBit bit opt = bit `setBitIf` gopt opt flags
+
+    setBitIf :: ExtBits -> Bool -> ExtsBitmap
+    b `setBitIf` cond | cond      = xbit b
+                      | otherwise = 0
 
 -- | Creates a parse state from a 'DynFlags' value
 mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
@@ -2331,6 +2506,7 @@ mkPStatePure options buf loc =
       alr_context = [],
       alr_expecting_ocurly = Nothing,
       alr_justClosedExplicitLetBlock = False,
+      use_pos_prags = True,
       annotations = [],
       comment_q = [],
       annotations_comments = []
@@ -2742,14 +2918,14 @@ reportLexError loc1 loc2 buf str
 lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
 lexTokenStream buf loc dflags = unP go initState
     where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
-          initState = mkPState dflags' buf loc
+          initState = (mkPState dflags' buf loc) { use_pos_prags = False }
           go = do
             ltok <- lexer False return
             case ltok of
               L _ ITeof -> return []
               _ -> liftM (ltok:) go
 
-linePrags = Map.singleton "line" (begin line_prag2)
+linePrags = Map.singleton "line" linePrag
 
 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
                                  ("options_ghc", lex_string_prag IToptions_prag),
@@ -2785,8 +2961,6 @@ oneWordPrags = Map.fromList [
      ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
      ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
      ("ann", strtoken (\s -> ITann_prag (SourceText s))),
-     ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))),
-     ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))),
      ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
      ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
      ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
@@ -2794,10 +2968,10 @@ oneWordPrags = Map.fromList [
      ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
      ("ctype", strtoken (\s -> ITctype (SourceText s))),
      ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
-     ("column", begin column_prag)
+     ("column", columnPrag)
      ]
 
-twoWordPrags = Map.fromList([
+twoWordPrags = Map.fromList [
      ("inline conlike",
          strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
      ("notinline conlike",
@@ -2805,9 +2979,8 @@ twoWordPrags = Map.fromList([
      ("specialize inline",
          strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
      ("specialize notinline",
-         strtoken (\s -> (ITspec_inline_prag (SourceText s) False))),
-     ("vectorize scalar",
-         strtoken (\s -> ITvect_scalar_prag (SourceText s)))])
+         strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
+     ]
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
@@ -2829,8 +3002,6 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                           canonical prag' = case prag' of
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"
-                                              "vectorise" -> "vectorize"
-                                              "novectorise" -> "novectorize"
                                               "constructorlike" -> "conlike"
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 672b6f74ab..dd9beadc4d 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -48,7 +48,7 @@ import PackageConfig
 import OrdList
 import BooleanFormula   ( BooleanFormula(..), LBooleanFormula(..), mkTrue )
 import FastString
-import Maybes           ( orElse )
+import Maybes           ( isJust, orElse )
 import Outputable
 
 -- compiler/basicTypes
@@ -76,21 +76,20 @@ import TcEvidence       ( emptyTcEvBinds )
 -- compiler/prelude
 import ForeignCall
 import TysPrim          ( eqPrimTyCon )
-import PrelNames        ( eqTyCon_RDR )
 import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
                           unboxedUnitTyCon, unboxedUnitDataCon,
-                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
+                          listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 
 -- compiler/utils
 import Util             ( looksLikePackageName )
-import Prelude
+import GhcPrelude
 
 import qualified GHC.LanguageExtensions as LangExt
 }
 
-%expect 36 -- shift/reduce conflicts
+%expect 235 -- shift/reduce conflicts
 
-{- Last updated: 3 Aug 2016
+{- Last updated: 04 June 2018
 
 If you modify this parser and add a conflict, please update this comment.
 You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -121,7 +120,7 @@ follows. Shift parses as if the 'module' keyword follows.
 
 -------------------------------------------------------------------------------
 
-state 48 contains 2 shift/reduce conflicts.
+state 57 contains 2 shift/reduce conflicts.
 
     *** strict_mark -> unpackedness .
         strict_mark -> unpackedness . strictness
@@ -130,7 +129,7 @@ state 48 contains 2 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 52 contains 1 shift/reduce conflict.
+state 61 contains 1 shift/reduce conflict.
 
         context -> btype .
     *** type -> btype .
@@ -140,16 +139,25 @@ state 52 contains 1 shift/reduce conflict.
 
 -------------------------------------------------------------------------------
 
-state 53 contains 9 shift/reduce conflicts.
+state 62 contains 46 shift/reduce conflicts.
 
     *** btype -> tyapps .
         tyapps -> tyapps . tyapp
 
-    Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+    Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE
+      VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM
+      STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE
+      and all the special ids.
+
+Example ambiguity:
+    'if x then y else z :: F a'
+
+Shift parses as (per longest-parse rule):
+    'if x then y else z :: (F a)'
 
 -------------------------------------------------------------------------------
 
-state 134 contains 14 shift/reduce conflicts.
+state 144 contains 15 shift/reduce conflicts.
 
         exp -> infixexp . '::' sigtype
         exp -> infixexp . '-<' exp
@@ -160,7 +168,7 @@ state 134 contains 14 shift/reduce conflicts.
         infixexp -> infixexp . qop exp10
 
     Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'
-               '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+               '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM
 
 Examples of ambiguity:
     'if x then y else z -< e'
@@ -174,7 +182,44 @@ Shift parses as (per longest-parse rule):
 
 -------------------------------------------------------------------------------
 
-state 299 contains 1 shift/reduce conflicts.
+state 149 contains 67 shift/reduce conflicts.
+
+    *** exp10 -> fexp .
+        fexp -> fexp . aexp
+        fexp -> fexp . TYPEAPP atype
+
+    Conflicts: TYPEAPP and all the tokens that can start an aexp
+
+Examples of ambiguity:
+    'if x then y else f z'
+    'if x then y else f @ z'
+
+Shift parses as (per longest-parse rule):
+    'if x then y else (f z)'
+    'if x then y else (f @ z)'
+
+-------------------------------------------------------------------------------
+
+state 204 contains 27 shift/reduce conflicts.
+
+        aexp2 -> TH_TY_QUOTE . tyvar
+        aexp2 -> TH_TY_QUOTE . gtycon
+    *** aexp2 -> TH_TY_QUOTE .
+
+    Conflicts: two single quotes is error syntax with specific error message.
+
+Example of ambiguity:
+    'x = '''
+    'x = ''a'
+    'x = ''T'
+
+Shift parses as (per longest-parse rule):
+    'x = ''a'
+    'x = ''T'
+
+-------------------------------------------------------------------------------
+
+state 300 contains 1 shift/reduce conflicts.
 
         rule -> STRING . rule_activation rule_forall infixexp '=' exp
 
@@ -192,18 +237,18 @@ a rule instructing how to rewrite the expression '[0] f'.
 
 -------------------------------------------------------------------------------
 
-state 309 contains 1 shift/reduce conflict.
+state 310 contains 1 shift/reduce conflict.
 
     *** type -> btype .
         type -> btype . '->' ctype
 
     Conflict: '->'
 
-Same as state 50 but without contexts.
+Same as state 61 but without contexts.
 
 -------------------------------------------------------------------------------
 
-state 348 contains 1 shift/reduce conflicts.
+state 354 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(' commas . ')'
@@ -218,7 +263,7 @@ if -XTupleSections is not specified.
 
 -------------------------------------------------------------------------------
 
-state 402 contains 1 shift/reduce conflicts.
+state 409 contains 1 shift/reduce conflicts.
 
         tup_exprs -> commas . tup_tail
         sysdcon_nolist -> '(#' commas . '#)'
@@ -226,22 +271,35 @@ state 402 contains 1 shift/reduce conflicts.
 
     Conflict: '#)' (empty tup_tail reduces)
 
-Same as State 324 for unboxed tuples.
+Same as State 354 for unboxed tuples.
+
+-------------------------------------------------------------------------------
+
+state 417 contains 67 shift/reduce conflicts.
+
+    *** exp10 -> '-' fexp .
+        fexp -> fexp . aexp
+        fexp -> fexp . TYPEAPP atype
+
+Same as 149 but with a unary minus.
 
 -------------------------------------------------------------------------------
 
-state 477 contains 1 shift/reduce conflict.
+state 481 contains 1 shift/reduce conflict.
 
         oqtycon -> '(' qtyconsym . ')'
     *** qtyconop -> qtyconsym .
 
     Conflict: ')'
 
-TODO: Why?
+Example ambiguity: 'foo :: (:%)'
+
+Shift means '(:%)' gets parsed as a type constructor, rather than than a
+parenthesized infix type expression of length 1.
 
 -------------------------------------------------------------------------------
 
-state 658 contains 1 shift/reduce conflicts.
+state 675 contains 1 shift/reduce conflicts.
 
     *** aexp2 -> ipvar .
         dbind -> ipvar . '=' exp
@@ -256,7 +314,7 @@ sensible meaning, namely the lhs of an implicit binding.
 
 -------------------------------------------------------------------------------
 
-state 731 contains 1 shift/reduce conflicts.
+state 752 contains 1 shift/reduce conflicts.
 
         rule -> STRING rule_activation . rule_forall infixexp '=' exp
 
@@ -273,7 +331,7 @@ doesn't include 'forall'.
 
 -------------------------------------------------------------------------------
 
-state 963 contains 1 shift/reduce conflicts.
+state 986 contains 1 shift/reduce conflicts.
 
         transformqual -> 'then' 'group' . 'using' exp
         transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -283,14 +341,25 @@ state 963 contains 1 shift/reduce conflicts.
 
 -------------------------------------------------------------------------------
 
-state 1303 contains 1 shift/reduce conflict.
+state 1367 contains 1 shift/reduce conflict.
 
     *** atype -> tyvar .
         tv_bndr -> '(' tyvar . '::' kind ')'
 
     Conflict: '::'
 
-TODO: Why?
+Example ambiguity: 'class C a where type D a = ( a :: * ...'
+
+Here the parser cannot tell whether this is specifying a default for the
+associated type like:
+
+'class C a where type D a = ( a :: * ); type D a'
+
+or it is an injectivity signature like:
+
+'class C a where type D a = ( r :: * ) | r -> a'
+
+Shift means the parser only allows the latter.
 
 -------------------------------------------------------------------------------
 -- API Annotations
@@ -414,6 +483,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  'static'       { L _ ITstatic }  -- for static pointers extension
  'stock'        { L _ ITstock }    -- for DerivingStrategies extension
  'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension
+ 'via'          { L _ ITvia }      -- for DerivingStrategies extension
 
  'unit'         { L _ ITunit }
  'signature'    { L _ ITsignature }
@@ -432,9 +502,6 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '{-# UNPACK'             { L _ (ITunpack_prag _) }
  '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }
  '{-# ANN'                { L _ (ITann_prag _) }
- '{-# VECTORISE'          { L _ (ITvect_prag _) }
- '{-# VECTORISE_SCALAR'   { L _ (ITvect_scalar_prag _) }
- '{-# NOVECTORISE'        { L _ (ITnovect_prag _) }
  '{-# MINIMAL'            { L _ (ITminimal_prag _) }
  '{-# CTYPE'              { L _ (ITctype _) }
  '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }
@@ -455,10 +522,10 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '->'           { L _ (ITrarrow _) }
  '@'            { L _ ITat }
  '~'            { L _ ITtilde }
- '~#'           { L _ ITtildehsh }
  '=>'           { L _ (ITdarrow _) }
  '-'            { L _ ITminus }
  '!'            { L _ ITbang }
+ '*'            { L _ (ITstar _) }
  '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation
  '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation
  '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation
@@ -558,7 +625,9 @@ identifier :: { Located RdrName }
         | qvarop                        { $1 }
         | qconop                        { $1 }
     | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
-                               [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] }
+                               [mop $1,mu AnnRarrow $2,mcp $3] }
+    | '(' '~' ')'       {% ams (sLL $1 $> $ eqTyCon_RDR)
+                               [mop $1,mj AnnTilde $2,mcp $3] }
 
 -----------------------------------------------------------------------------
 -- Backpack stuff
@@ -781,9 +850,9 @@ expdoclist :: { OrdList (LIE GhcPs) }
         | {- empty -}                                  { nilOL }
 
 exp_doc :: { OrdList (LIE GhcPs) }
-        : docsection    { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }
-        | docnamed      { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) }
-        | docnext       { unitOL (sL1 $1 (IEDoc (unLoc $1))) }
+        : docsection    { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExt n doc)) }
+        | docnamed      { unitOL (sL1 $1 (IEDocNamed noExt ((fst . unLoc) $1))) }
+        | docnext       { unitOL (sL1 $1 (IEDoc noExt (unLoc $1))) }
 
 
    -- No longer allow things like [] and (,,,) to be exported
@@ -791,9 +860,9 @@ exp_doc :: { OrdList (LIE GhcPs) }
 export  :: { OrdList (LIE GhcPs) }
         : qcname_ext export_subspec  {% mkModuleImpExp $1 (snd $ unLoc $2)
                                           >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }
-        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
+        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents noExt $2))
                                              [mj AnnModule $1] }
-        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2))))
+        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar noExt (sLL $1 $> (IEPattern $2))))
                                              [mj AnnPattern $1] }
 
 export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
@@ -870,7 +939,8 @@ importdecls_semi
 importdecl :: { LImportDecl GhcPs }
         : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
                 {% ams (L (comb4 $1 $6 (snd $7) $8) $
-                  ImportDecl { ideclSourceSrc = snd $ fst $2
+                  ImportDecl { ideclExt = noExt
+                             , ideclSourceSrc = snd $ fst $2
                              , ideclName = $6, ideclPkgQual = snd $5
                              , ideclSource = snd $2, ideclSafe = snd $3
                              , ideclQualified = snd $4, ideclImplicit = False
@@ -953,49 +1023,22 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) }
         | {- empty -}                  { nilOL }
 
 topdecl :: { LHsDecl GhcPs }
-        : cl_decl                               { sL1 $1 (TyClD (unLoc $1)) }
-        | ty_decl                               { sL1 $1 (TyClD (unLoc $1)) }
-        | inst_decl                             { sL1 $1 (InstD (unLoc $1)) }
-        | stand_alone_deriving                  { sLL $1 $> (DerivD (unLoc $1)) }
-        | role_annot                            { sL1 $1 (RoleAnnotD (unLoc $1)) }
-        | 'default' '(' comma_types0 ')'    {% ams (sLL $1 $> (DefD (DefaultDecl $3)))
+        : cl_decl                               { sL1 $1 (TyClD noExt (unLoc $1)) }
+        | ty_decl                               { sL1 $1 (TyClD noExt (unLoc $1)) }
+        | inst_decl                             { sL1 $1 (InstD noExt (unLoc $1)) }
+        | stand_alone_deriving                  { sLL $1 $> (DerivD noExt (unLoc $1)) }
+        | role_annot                            { sL1 $1 (RoleAnnotD noExt (unLoc $1)) }
+        | 'default' '(' comma_types0 ')'    {% ams (sLL $1 $> (DefD noExt (DefaultDecl noExt $3)))
                                                          [mj AnnDefault $1
                                                          ,mop $2,mcp $4] }
         | 'foreign' fdecl          {% ams (sLL $1 $> (snd $ unLoc $2))
                                            (mj AnnForeign $1:(fst $ unLoc $2)) }
-        | '{-# DEPRECATED' deprecations '#-}'   {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
+        | '{-# DEPRECATED' deprecations '#-}'   {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs $1) (fromOL $2)))
                                                        [mo $1,mc $3] }
-        | '{-# WARNING' warnings '#-}'          {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))
+        | '{-# WARNING' warnings '#-}'          {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getWARNING_PRAGs $1) (fromOL $2)))
                                                        [mo $1,mc $3] }
-        | '{-# RULES' rules '#-}'               {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))
+        | '{-# RULES' rules '#-}'               {% ams (sLL $1 $> $ RuleD noExt (HsRules noExt (getRULES_PRAGs $1) (fromOL $2)))
                                                        [mo $1,mc $3] }
-        | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))
-                                                    [mo $1,mj AnnEqual $3
-                                                    ,mc $5] }
-        | '{-# NOVECTORISE' qvar '#-}'       {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))
-                                                     [mo $1,mc $3] }
-        | '{-# VECTORISE' 'type' gtycon '#-}'
-                                {% ams (sLL $1 $> $
-                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))
-                                    [mo $1,mj AnnType $2,mc $4] }
-
-        | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
-                                {% ams (sLL $1 $> $
-                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))
-                                    [mo $1,mj AnnType $2,mc $4] }
-
-        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
-                                {% ams (sLL $1 $> $
-                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))
-                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
-        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
-                                {% ams (sLL $1 $> $
-                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))
-                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
-
-        | '{-# VECTORISE' 'class' gtycon '#-}'
-                                         {% ams (sLL $1 $>  $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))
-                                                 [mo $1,mj AnnClass $2,mc $4] }
         | annotation { $1 }
         | decl_no_th                            { $1 }
 
@@ -1066,12 +1109,13 @@ ty_decl :: { LTyClDecl GhcPs }
 inst_decl :: { LInstDecl GhcPs }
         : 'instance' overlap_pragma inst_type where_inst
        {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
-             ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
+             ; let cid = ClsInstDecl { cid_ext = noExt
+                                     , cid_poly_ty = $3, cid_binds = binds
                                      , cid_sigs = mkClassOpSigs sigs
                                      , cid_tyfam_insts = ats
                                      , cid_overlap_mode = $2
                                      , cid_datafam_insts = adts }
-             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid }))
+             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid }))
                    (mj AnnInstance $1 : (fst $ unLoc $4)) } }
 
            -- type instance declarations
@@ -1109,13 +1153,26 @@ overlap_pragma :: { Maybe (Located OverlapMode) }
                                        [mo $1,mc $2] }
   | {- empty -}                 { Nothing }
 
-deriv_strategy :: { Maybe (Located DerivStrategy) }
+deriv_strategy_no_via :: { LDerivStrategy GhcPs }
+  : 'stock'                     {% ams (sL1 $1 StockStrategy)
+                                       [mj AnnStock $1] }
+  | 'anyclass'                  {% ams (sL1 $1 AnyclassStrategy)
+                                       [mj AnnAnyclass $1] }
+  | 'newtype'                   {% ams (sL1 $1 NewtypeStrategy)
+                                       [mj AnnNewtype $1] }
+
+deriv_strategy_via :: { LDerivStrategy GhcPs }
+  : 'via' type              {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))
+                                            [mj AnnVia $1] }
+
+deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
   : 'stock'                     {% ajs (Just (sL1 $1 StockStrategy))
                                        [mj AnnStock $1] }
   | 'anyclass'                  {% ajs (Just (sL1 $1 AnyclassStrategy))
                                        [mj AnnAnyclass $1] }
   | 'newtype'                   {% ajs (Just (sL1 $1 NewtypeStrategy))
                                        [mj AnnNewtype $1] }
+  | deriv_strategy_via          { Just $1 }
   | {- empty -}                 { Nothing }
 
 -- Injective type families
@@ -1154,21 +1211,23 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
 
 ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
         : ty_fam_inst_eqns ';' ty_fam_inst_eqn
-                                      {% asl (unLoc $1) $2 (snd $ unLoc $3)
-                                         >> ams $3 (fst $ unLoc $3)
-                                         >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }
+                                      {% let L loc (anns, eqn) = $3 in
+                                         asl (unLoc $1) $2 (L loc eqn)
+                                         >> ams $3 anns
+                                         >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
         | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
                                          >> return (sLL $1 $>  (unLoc $1)) }
-        | ty_fam_inst_eqn             {% ams $1 (fst $ unLoc $1)
-                                         >> return (sLL $1 $> [snd $ unLoc $1]) }
+        | ty_fam_inst_eqn             {% let L loc (anns, eqn) = $1 in
+                                         ams $1 anns
+                                         >> return (sLL $1 $> [L loc eqn]) }
         | {- empty -}                 { noLoc [] }
 
-ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) }
+ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
         : type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
               {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
-                    ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn))  } }
+                    ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn))  } }
 
 -- Associated type family declarations
 --
@@ -1273,22 +1332,22 @@ opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) }
         | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], Just $2) }
 
 opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
-        :               { noLoc     ([]               , noLoc NoSig           )}
-        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))}
+        :               { noLoc     ([]               , noLoc (NoSig noExt)         )}
+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))}
 
 opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }
-        :              { noLoc     ([]               , noLoc      NoSig       )}
-        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig  $2))}
-        | '='  tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))}
+        :              { noLoc     ([]               , noLoc     (NoSig    noExt)   )}
+        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig  noExt $2))}
+        | '='  tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExt $2))}
 
 opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs
                                             , Maybe (LInjectivityAnn GhcPs)))}
-        :            { noLoc ([], (noLoc NoSig, Nothing)) }
+        :            { noLoc ([], (noLoc (NoSig noExt), Nothing)) }
         | '::' kind  { sLL $1 $> ( [mu AnnDcolon $1]
-                                 , (sLL $2 $> (KindSig $2), Nothing)) }
+                                 , (sLL $2 $> (KindSig noExt $2), Nothing)) }
         | '='  tv_bndr '|' injectivity_cond
                 { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]
-                            , (sLL $1 $2 (TyVarSig $2), Just $4))}
+                            , (sLL $1 $2 (TyVarSig noExt $2), Just $4))}
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -1320,10 +1379,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
 
 -- Glasgow extension: stand-alone deriving declarations
 stand_alone_deriving :: { LDerivDecl GhcPs }
-  : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
+  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
                 {% do { let { err = text "in the stand-alone deriving instance"
                                     <> colon <+> quotes (ppr $5) }
-                      ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+                      ; ams (sLL $1 (hsSigType $>)
+                                 (DerivDecl noExt (mkHsWildCardBndrs $5) $2 $4))
                             [mj AnnDeriving $1, mj AnnInstance $3] } }
 
 -----------------------------------------------------------------------------
@@ -1354,28 +1414,28 @@ role : VARID             { sL1 $1 $ Just $ getVARID $1 }
 pattern_synonym_decl :: { LHsDecl GhcPs }
         : 'pattern' pattern_synonym_lhs '=' pat
          {%      let (name, args,as ) = $2 in
-                 ams (sLL $1 $> . ValD $ mkPatSynBind name args $4
+                 ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4
                                                     ImplicitBidirectional)
                (as ++ [mj AnnPattern $1, mj AnnEqual $3])
          }
 
         | 'pattern' pattern_synonym_lhs '<-' pat
          {%    let (name, args, as) = $2 in
-               ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
+               ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 Unidirectional)
                (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }
 
         | 'pattern' pattern_synonym_lhs '<-' pat where_decls
             {% do { let (name, args, as) = $2
                   ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
-                  ; ams (sLL $1 $> . ValD $
+                  ; ams (sLL $1 $> . ValD noExt $
                            mkPatSynBind name args $4 (ExplicitBidirectional mg))
                        (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )
                    }}
 
 pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
-        : con vars0 { ($1, PrefixPatSyn $2, []) }
-        | varid conop varid { ($2, InfixPatSyn $1 $3, []) }
-        | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }
+        : con vars0 { ($1, PrefixCon $2, []) }
+        | varid conop varid { ($2, InfixCon $1 $3, []) }
+        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
@@ -1395,7 +1455,7 @@ where_decls :: { Located ([AddAnn]
 
 pattern_synonym_sig :: { LSig GhcPs }
         : 'pattern' con_list '::' sigtypedoc
-                   {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4))
+                   {% ams (sLL $1 $> $ PatSynSig noExt (unLoc $2) (mkLHsSigType $4))
                           [mj AnnPattern $1, mu AnnDcolon $3] }
 
 -----------------------------------------------------------------------------
@@ -1412,7 +1472,7 @@ decl_cls  : at_decl_cls                 { $1 }
                     {% do { v <- checkValSigLhs $2
                           ; let err = text "in default signature" <> colon <+>
                                       quotes (ppr $2)
-                          ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)
+                          ; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4)
                                 [mj AnnDefault $1,mu AnnDcolon $3] } }
 
 decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed
@@ -1450,7 +1510,7 @@ where_cls :: { Located ([AddAnn]
 -- Declarations in instance bodies
 --
 decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }
-decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) }
+decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD noExt (unLoc $1)))) }
            | decl                       { sLL $1 $> (unitOL $1) }
 
 decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed
@@ -1518,15 +1578,13 @@ binds   ::  { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
                                                 -- No type declarations
         : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
                                   ; return (sL1 $1 (fst $ unLoc $1
-                                                    ,sL1 $1 $ HsValBinds val_binds)) } }
+                                                    ,sL1 $1 $ HsValBinds noExt val_binds)) } }
 
         | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
-                                             ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
-                                                         emptyTcEvBinds)) }
+                                             ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
         |     vocurly    dbinds close   { L (getLoc $2) ([]
-                                            ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
-                                                        emptyTcEvBinds)) }
+                                            ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
 
 wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
@@ -1550,10 +1608,9 @@ rules   :: { OrdList (LRuleDecl GhcPs) }
 
 rule    :: { LRuleDecl GhcPs }
         : STRING rule_activation rule_forall infixexp '=' exp
-         {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1))
+         {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1))
                                   ((snd $2) `orElse` AlwaysActive)
-                                  (snd $3) $4 placeHolderNames $6
-                                  placeHolderNames))
+                                  (snd $3) $4 $6))
                (mj AnnEqual $5 : (fst $2) ++ (fst $3)) }
 
 -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1579,8 +1636,8 @@ rule_var_list :: { [LRuleBndr GhcPs] }
         | rule_var rule_var_list                { $1 : $2 }
 
 rule_var :: { LRuleBndr GhcPs }
-        : varid                         { sLL $1 $> (RuleBndr $1) }
-        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig $2
+        : varid                         { sLL $1 $> (RuleBndr noExt $1) }
+        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleBndrSig noExt $2
                                                        (mkLHsSigWcType $4)))
                                                [mop $1,mu AnnDcolon $3,mcp $5] }
 
@@ -1598,7 +1655,7 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 warning :: { OrdList (LWarnDecl GhcPs) }
         : namelist strings
-                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
+                {% amsu (sLL $1 $> (Warning noExt (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
 deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -1613,7 +1670,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 deprecation :: { OrdList (LWarnDecl GhcPs) }
         : namelist strings
-             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
+             {% amsu (sLL $1 $> $ (Warning noExt (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
 strings :: { Located ([AddAnn],[Located StringLiteral]) }
@@ -1630,17 +1687,17 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
 -----------------------------------------------------------------------------
 -- Annotations
 annotation :: { LHsDecl GhcPs }
-    : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
+    : '{-# ANN' name_var aexp '#-}'      {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                             (getANN_PRAGs $1)
                                             (ValueAnnProvenance $2) $3))
                                             [mo $1,mc $4] }
 
-    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD $ HsAnnotation
+    | '{-# ANN' 'type' tycon aexp '#-}'  {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                             (getANN_PRAGs $1)
                                             (TypeAnnProvenance $3) $4))
                                             [mo $1,mj AnnType $2,mc $5] }
 
-    | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD $ HsAnnotation
+    | '{-# ANN' 'module' aexp '#-}'      {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt
                                                 (getANN_PRAGs $1)
                                                  ModuleAnnProvenance $3))
                                                 [mo $1,mj AnnModule $2,mc $4] }
@@ -1690,10 +1747,6 @@ opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }
         : {- empty -}                   { ([],Nothing) }
         | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }
 
-opt_asig :: { ([AddAnn],Maybe (LHsType GhcPs)) }
-        : {- empty -}                   { ([],Nothing) }
-        | '::' atype                    { ([mu AnnDcolon $1],Just $2) }
-
 opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }
              : {- empty -}              { ([], Nothing) }
              | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }
@@ -1741,13 +1794,15 @@ ctype   :: { LHsType GhcPs }
         : 'forall' tv_bndrs '.' ctype   {% hintExplicitForall (getLoc $1) >>
                                            ams (sLL $1 $> $
                                                 HsForAllTy { hst_bndrs = $2
+                                                           , hst_xforall = noExt
                                                            , hst_body = $4 })
                                                [mu AnnForall $1, mj AnnDot $3] }
         | context '=>' ctype          {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
                                          >> return (sLL $1 $> $
                                             HsQualTy { hst_ctxt = $1
+                                                     , hst_xqual = noExt
                                                      , hst_body = $3 }) }
-        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy $1 $3))
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
                                              [mu AnnDcolon $2] }
         | type                        { $1 }
 
@@ -1766,13 +1821,15 @@ ctypedoc :: { LHsType GhcPs }
         : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
                                             ams (sLL $1 $> $
                                                  HsForAllTy { hst_bndrs = $2
+                                                            , hst_xforall = noExt
                                                             , hst_body = $4 })
                                                 [mu AnnForall $1,mj AnnDot $3] }
         | context '=>' ctypedoc       {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)
                                          >> return (sLL $1 $> $
                                             HsQualTy { hst_ctxt = $1
+                                                     , hst_xqual = noExt
                                                      , hst_body = $3 }) }
-        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy $1 $3))
+        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy noExt $1 $3))
                                              [mu AnnDcolon $2] }
         | typedoc                     { $1 }
 
@@ -1797,7 +1854,7 @@ context :: { LHsContext GhcPs }
                                                 } }
 
 context_no_ops :: { LHsContext GhcPs }
-        : btype_no_ops                 {% do { ty <- splitTilde $1
+        : btype_no_ops                 {% do { ty <- splitTilde (reverse (unLoc $1))
                                              ; (anns,ctx) <- checkContext ty
                                              ; if null (unLoc ctx)
                                                    then addAnnotation (gl ty) AnnUnit (gl ty)
@@ -1809,9 +1866,10 @@ context_no_ops :: { LHsContext GhcPs }
 ~~~~~~~~~~~~~~~~~~~~~
 The type production for
 
-    btype `->` btype
+    btype `->`         ctypedoc
+    btype docprev `->` ctypedoc
 
-adds the AnnRarrow annotation twice, in different places.
+add the AnnRarrow annotation twice, in different places.
 
 This is because if the type is processed as usual, it belongs on the annotations
 for the type as a whole.
@@ -1824,91 +1882,106 @@ is connected to the first type too.
 type :: { LHsType GhcPs }
         : btype                        { $1 }
         | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
-                                       >> ams (sLL $1 $> $ HsFunTy $1 $3)
+                                       >> ams (sLL $1 $> $ HsFunTy noExt $1 $3)
                                               [mu AnnRarrow $2] }
 
 
 typedoc :: { LHsType GhcPs }
         : btype                          { $1 }
-        | btype docprev                  { sLL $1 $> $ HsDocTy $1 $2 }
-        | btype '->'     ctypedoc        {% ams (sLL $1 $> $ HsFunTy $1 $3)
+        | btype docprev                  { sLL $1 $> $ HsDocTy noExt $1 $2 }
+        | docnext btype                  { sLL $1 $> $ HsDocTy noExt $2 $1 }
+        | btype '->'     ctypedoc        {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
+                                         >> ams (sLL $1 $> $ HsFunTy noExt $1 $3)
                                                 [mu AnnRarrow $2] }
-        | btype docprev '->' ctypedoc    {% ams (sLL $1 $> $
-                                                 HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
+        | btype docprev '->' ctypedoc    {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+                                         >> ams (sLL $1 $> $
+                                                 HsFunTy noExt (L (comb2 $1 $2)
+                                                            (HsDocTy noExt $1 $2))
+                                                         $4)
+                                                [mu AnnRarrow $3] }
+        | docnext btype '->' ctypedoc    {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
+                                         >> ams (sLL $1 $> $
+                                                 HsFunTy noExt (L (comb2 $1 $2)
+                                                            (HsDocTy noExt $2 $1))
                                                          $4)
                                                 [mu AnnRarrow $3] }
 
+
+
 -- See Note [Parsing ~]
 btype :: { LHsType GhcPs }
-        : tyapps                      {%  splitTildeApps (reverse (unLoc $1)) >>=
-                                          \ts -> return $ sL1 $1 $ HsAppsTy ts }
+      : tyapps                      {%  mergeOps (unLoc $1) }
 
 -- Used for parsing Haskell98-style data constructors,
 -- in order to forbid the blasphemous
 -- > data Foo = Int :+ Char :* Bool
 -- See also Note [Parsing data constructors is hard] in RdrHsSyn
-btype_no_ops :: { LHsType GhcPs }
-        : btype_no_ops atype            { sLL $1 $> $ HsAppTy $1 $2 }
-        | atype                         { $1 }
+btype_no_ops :: { Located [LHsType GhcPs] } -- NB: This list is reversed
+        : atype_docs                    { sL1 $1 [$1] }
+        | btype_no_ops atype_docs       { sLL $1 $> $ $2 : (unLoc $1) }
 
-tyapps :: { Located [LHsAppType GhcPs] }   -- NB: This list is reversed
+tyapps :: { Located [Located TyEl] } -- NB: This list is reversed
         : tyapp                         { sL1 $1 [$1] }
         | tyapps tyapp                  { sLL $1 $> $ $2 : (unLoc $1) }
 
--- See Note [HsAppsTy] in HsTypes
-tyapp :: { LHsAppType GhcPs }
-        : atype                         { sL1 $1 $ HsAppPrefix $1 }
-        | qtyconop                      { sL1 $1 $ HsAppInfix $1 }
-        | tyvarop                       { sL1 $1 $ HsAppInfix $1 }
-        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix $2)
-                                               [mj AnnSimpleQuote $1] }
-        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)
-                                               [mj AnnSimpleQuote $1] }
+tyapp :: { Located TyEl }
+        : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }
+        | qtyconop                      { sL1 $1 $ TyElOpr (unLoc $1) }
+        | tyvarop                       { sL1 $1 $ TyElOpr (unLoc $1) }
+        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
+                                               [mj AnnSimpleQuote $1,mj AnnVal $2] }
+        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
+                                               [mj AnnSimpleQuote $1,mj AnnVal $2] }
+
+atype_docs :: { LHsType GhcPs }
+        : atype docprev                 { sLL $1 $> $ HsDocTy noExt $1 $2 }
+        | atype                         { $1 }
 
 atype :: { LHsType GhcPs }
-        : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }      -- Not including unit tuples
-        | tyvar                          { sL1 $1 (HsTyVar NotPromoted $1) }      -- (See Note [Unit tuples])
-        | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
+        : ntgtycon                       { sL1 $1 (HsTyVar noExt NotPromoted $1) }      -- Not including unit tuples
+        | tyvar                          { sL1 $1 (HsTyVar noExt NotPromoted $1) }      -- (See Note [Unit tuples])
+        | '*'                            {% do { warnStarIsType (getLoc $1)
+                                               ; return $ sL1 $1 (HsStarTy noExt (isUnicode $1)) } }
+        | strict_mark atype              {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2))
                                                 (fst $ unLoc $1) }  -- Constructor sigs only
         | '{' fielddecls '}'             {% amms (checkRecordSyntax
-                                                    (sLL $1 $> $ HsRecTy $2))
+                                                    (sLL $1 $> $ HsRecTy noExt $2))
                                                         -- Constructor sigs only
                                                  [moc $1,mcc $3] }
-        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy
+        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy noExt
                                                     HsBoxedOrConstraintTuple [])
                                                 [mop $1,mcp $2] }
         | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma
                                                           (gl $3) >>
-                                            ams (sLL $1 $> $ HsTupleTy
+                                            ams (sLL $1 $> $ HsTupleTy noExt
+
                                              HsBoxedOrConstraintTuple ($2 : $4))
                                                 [mop $1,mcp $5] }
-        | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple [])
+        | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple [])
                                              [mo $1,mc $2] }
-        | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2)
+        | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2)
                                              [mo $1,mc $3] }
-        | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy $2)
+        | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy noExt $2)
                                              [mo $1,mc $3] }
-        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  $2) [mos $1,mcs $3] }
-        | '[:' ctype ':]'             {% ams (sLL $1 $> $ HsPArrTy  $2) [mo $1,mc $3] }
-        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   $2) [mop $1,mcp $3] }
-        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
+        | '[' ctype ']'               {% ams (sLL $1 $> $ HsListTy  noExt $2) [mos $1,mcs $3] }
+        | '(' ctype ')'               {% ams (sLL $1 $> $ HsParTy   noExt $2) [mop $1,mcp $3] }
+        | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig noExt $2 $4)
                                              [mop $1,mu AnnDcolon $3,mcp $5] }
-        | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
+        | quasiquote                  { sL1 $1 (HsSpliceTy noExt (unLoc $1) ) }
         | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
                                              [mj AnnOpenPE $1,mj AnnCloseP $3] }
-        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $
+        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $
                                              (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
                                              [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
-                                ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
+                                ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
                                     [mj AnnSimpleQuote $1,mop $2,mcp $6] }
-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy Promoted
-                                                            placeHolderKind $3)
+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3)
                                                        [mj AnnSimpleQuote $1,mos $2,mcs $4] }
-        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar Promoted $2)
+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2)
                                                        [mj AnnSimpleQuote $1,mj AnnName $2] }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
@@ -1917,13 +1990,12 @@ atype :: { LHsType GhcPs }
         -- so you have to quote those.)
         | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
                                                            (gl $3) >>
-                                             ams (sLL $1 $> $ HsExplicitListTy NotPromoted
-                                                     placeHolderKind ($2 : $4))
+                                             ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4))
                                                  [mos $1,mcs $5] }
-        | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
-                                                               (il_value (getINTEGER $1)) }
-        | STRING               { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1)
-                                                               (getSTRING  $1) }
+        | INTEGER              { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1)
+                                                           (il_value (getINTEGER $1)) }
+        | STRING               { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1)
+                                                                     (getSTRING  $1) }
         | '_'                  { sL1 $1 $ mkAnonWildCardTy }
 
 -- An inst_type is what occurs in the head of an instance decl
@@ -1958,8 +2030,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] }
          | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr GhcPs }
-        : tyvar                         { sL1 $1 (UserTyVar $1) }
-        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar $2 $4))
+        : tyvar                         { sL1 $1 (UserTyVar noExt $1) }
+        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $>  (KindedTyVar noExt $2 $4))
                                                [mop $1,mu AnnDcolon $3
                                                ,mcp $5] }
 
@@ -1988,13 +2060,13 @@ Note [Parsing ~]
 
 Due to parsing conflicts between laziness annotations in data type
 declarations (see strict_mark) and equality types ~'s are always
-parsed as laziness annotations, and turned into HsEqTy's in the
+parsed as laziness annotations, and turned into HsOpTy's in the
 correct places using RdrHsSyn.splitTilde.
 
 Since strict_mark is parsed as part of atype which is part of type,
 typedoc and context (where HsEqTy previously appeared) it made most
 sense and was simplest to parse ~ as part of strict_mark and later
-turn them into HsEqTy's.
+turn them into HsOpTy's.
 
 -}
 
@@ -2032,14 +2104,17 @@ both become a HsTyVar ("Zero", DataName) after the renamer.
 
 gadt_constrlist :: { Located ([AddAnn]
                           ,[LConDecl GhcPs]) } -- Returned in order
-        : 'where' '{'        gadt_constrs '}'   { L (comb2 $1 $3)
-                                                    ([mj AnnWhere $1
-                                                     ,moc $2
-                                                     ,mcc $4]
-                                                    , unLoc $3) }
-        | 'where' vocurly    gadt_constrs close  { L (comb2 $1 $3)
-                                                     ([mj AnnWhere $1]
-                                                     , unLoc $3) }
+
+        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $
+                                                      L (comb2 $1 $3)
+                                                        ([mj AnnWhere $1
+                                                         ,moc $2
+                                                         ,mcc $4]
+                                                        , unLoc $3) }
+        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $
+                                                      L (comb2 $1 $3)
+                                                        ([mj AnnWhere $1]
+                                                        , unLoc $3) }
         | {- empty -}                            { noLoc ([],[]) }
 
 gadt_constrs :: { Located [LConDecl GhcPs] }
@@ -2065,9 +2140,10 @@ gadt_constr_with_doc
 gadt_constr :: { LConDecl GhcPs }
     -- see Note [Difference in parsing GADT and data constructors]
     -- Returns a list because of:   C,D :: ty
-        : con_list '::' sigtype
-                {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3)))
-                       [mu AnnDcolon $2] }
+        : con_list '::' sigtypedoc
+                {% let (gadt,anns) = mkGadtDecl (unLoc $1) $3
+                   in ams (sLL $1 $> gadt)
+                       (mu AnnDcolon $2:anns) }
 
 {- Note [Difference in parsing GADT and data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2092,29 +2168,39 @@ constrs1 :: { Located [LConDecl GhcPs] }
         | constr                                          { sL1 $1 [$1] }
 
 constr :: { LConDecl GhcPs }
-        : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
-                {% ams (let (con,details) = unLoc $5 in
+        : maybe_docnext forall context_no_ops '=>' constr_stuff
+                {% ams (let (con,details,doc_prev) = unLoc $5 in
                   addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
-                                                   (snd $ unLoc $2) $3 details))
-                            ($1 `mplus` $6))
+                                                       (snd $ unLoc $2)
+                                                       (Just $3)
+                                                       details))
+                            ($1 `mplus` doc_prev))
                         (mu AnnDarrow $4:(fst $ unLoc $2)) }
-        | maybe_docnext forall constr_stuff maybe_docprev
-                {% ams ( let (con,details) = unLoc $3 in
+        | maybe_docnext forall constr_stuff
+                {% ams ( let (con,details,doc_prev) = unLoc $3 in
                   addConDoc (L (comb2 $2 $3) (mkConDeclH98 con
-                                           (snd $ unLoc $2) (noLoc []) details))
-                            ($1 `mplus` $4))
+                                                      (snd $ unLoc $2)
+                                                      Nothing   -- No context
+                                                      details))
+                            ($1 `mplus` doc_prev))
                        (fst $ unLoc $2) }
 
 forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) }
         : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
+constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString) }
     -- See Note [Parsing data constructors is hard] in RdrHsSyn
-        : btype_no_ops                         {% do { c <- splitCon $1
-                                                     ; return $ sLL $1 $> c } }
-        | btype_no_ops conop btype_no_ops      {% do { ty <- splitTilde $1
-                                                     ; return $ sLL $1 $> ($2, InfixCon ty $3) } }
+        : btype_no_ops                     {% do { c <- splitCon (unLoc $1)
+                                                 ; return $ sL1 $1 c } }
+        | btype_no_ops conop maybe_docprev btype_no_ops
+            {% do { lhs <- splitTilde (reverse (unLoc $1))
+                  ; (_, ds_l) <- checkInfixConstr lhs
+                  ; let rhs1 = foldl1 mkHsAppTy (reverse (unLoc $4))
+                  ; (rhs, ds_r) <- checkInfixConstr rhs1
+                  ; return $ if isJust (ds_l `mplus` $3)
+                               then sLL $1 $> ($2, InfixCon lhs rhs1, $3)
+                               else sLL $1 $> ($2, InfixCon lhs rhs, ds_r) } }
 
 fielddecls :: { [LConDeclField GhcPs] }
         : {- empty -}     { [] }
@@ -2130,7 +2216,7 @@ fielddecl :: { LConDeclField GhcPs }
                                               -- A list because of   f,g :: Int
         : maybe_docnext sig_vars '::' ctype maybe_docprev
             {% ams (L (comb2 $2 $4)
-                      (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5)))
+                      (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5)))
                    [mu AnnDcolon $3] }
 
 -- Reversed!
@@ -2146,21 +2232,27 @@ derivings :: { HsDeriving GhcPs }
 -- The outer Located is just to allow the caller to
 -- know the rightmost extremity of the 'deriving' clause
 deriving :: { LHsDerivingClause GhcPs }
-        : 'deriving' deriv_strategy qtycondoc
+        : 'deriving' deriv_clause_types
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc
-                            [mkLHsSigType $3])
+                 in ams (L full_loc $ HsDerivingClause noExt Nothing $2)
                         [mj AnnDeriving $1] }
 
-        | 'deriving' deriv_strategy '(' ')'
+        | 'deriving' deriv_strategy_no_via deriv_clause_types
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc [])
-                        [mj AnnDeriving $1,mop $3,mcp $4] }
+                 in ams (L full_loc $ HsDerivingClause noExt (Just $2) $3)
+                        [mj AnnDeriving $1] }
 
-        | 'deriving' deriv_strategy '(' deriv_types ')'
+        | 'deriving' deriv_clause_types deriv_strategy_via
               {% let { full_loc = comb2 $1 $> }
-                 in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4)
-                        [mj AnnDeriving $1,mop $3,mcp $5] }
+                 in ams (L full_loc $ HsDerivingClause noExt (Just $3) $2)
+                        [mj AnnDeriving $1] }
+
+deriv_clause_types :: { Located [LHsSigType GhcPs] }
+        : qtycondoc           { sL1 $1 [mkLHsSigType $1] }
+        | '(' ')'             {% ams (sLL $1 $> [])
+                                     [mop $1,mcp $2] }
+        | '(' deriv_types ')' {% ams (sLL $1 $> $2)
+                                     [mop $1,mcp $3] }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
@@ -2190,7 +2282,7 @@ There's an awkward overlap with a type signature.  Consider
 -}
 
 docdecl :: { LHsDecl GhcPs }
-        : docdecld { sL1 $1 (DocD (unLoc $1)) }
+        : docdecld { sL1 $1 (DocD noExt (unLoc $1)) }
 
 docdecld :: { LDocDecl }
         : docnext                               { sL1 $1 (DocCommentNext (unLoc $1)) }
@@ -2201,35 +2293,34 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
-        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)
-                                              -- Turn it all into an expression so that
-                                              -- checkPattern can check that bangs are enabled
+        | '!' aexp rhs          {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)
                                             ; l = comb2 $1 $> };
                                         (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ;
+                                        hintBangPat (comb2 $1 $2) (unLoc e) ;
                                         -- Depending upon what the pattern looks like we might get either
                                         -- a FunBind or PatBind back from checkValDef. See Note
-                                        -- [Varieties of binding pattern matches]
+                                        -- [FunBind vs PatBind]
                                         case r of {
-                                          (FunBind n _ _ _ _) ->
+                                          (FunBind _ n _ _ _) ->
                                                 ams (L l ()) [mj AnnFunId n] >> return () ;
-                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                          (PatBind _ (L lh _lhs) _rhs _) ->
                                                 ams (L lh ()) [] >> return () } ;
 
                                         _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
-                                        return $! (sL l $ ValD r) } }
+                                        return $! (sL l $ ValD noExt r) } }
 
         | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         -- Depending upon what the pattern looks like we might get either
                                         -- a FunBind or PatBind back from checkValDef. See Note
-                                        -- [Varieties of binding pattern matches]
+                                        -- [FunBind vs PatBind]
                                         case r of {
-                                          (FunBind n _ _ _ _) ->
+                                          (FunBind _ n _ _ _) ->
                                                 ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
-                                          (PatBind (L lh _lhs) _rhs _ _ _) ->
+                                          (PatBind _ (L lh _lhs) _rhs _) ->
                                                 ams (L lh ()) (fst $2) >> return () } ;
                                         _ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
-                                        return $! (sL l $ ValD r) } }
+                                        return $! (sL l $ ValD noExt r) } }
         | pattern_synonym_decl  { $1 }
         | docdecl               { $1 }
 
@@ -2244,10 +2335,10 @@ decl    :: { LHsDecl GhcPs }
 rhs     :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
         : '=' exp wherebinds    { sL (comb3 $1 $2 $3)
                                     ((mj AnnEqual $1 : (fst $ unLoc $3))
-                                    ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2)
+                                    ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2)
                                    (snd $ unLoc $3)) }
         | gdrhs wherebinds      { sLL $1 $>  (fst $ unLoc $2
-                                    ,GRHSs (reverse (unLoc $1))
+                                    ,GRHSs noExt (reverse (unLoc $1))
                                                     (snd $ unLoc $2)) }
 
 gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
@@ -2255,7 +2346,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
         | gdrh                  { sL1 $1 [$1] }
 
 gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
-        : '|' guardquals '=' exp  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+        : '|' guardquals '=' exp  {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
                                          [mj AnnVbar $1,mj AnnEqual $3] }
 
 sigdecl :: { LHsDecl GhcPs }
@@ -2264,69 +2355,69 @@ sigdecl :: { LHsDecl GhcPs }
           infixexp_top '::' sigtypedoc
                         {% do v <- checkValSigLhs $1
                         ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
-                        ; return (sLL $1 $> $ SigD $
-                                  TypeSig [v] (mkLHsSigWcType $3)) }
+                        ; return (sLL $1 $> $ SigD noExt $
+                                  TypeSig noExt [v] (mkLHsSigWcType $3)) }
 
         | var ',' sig_vars '::' sigtypedoc
-           {% do { let sig = TypeSig ($1 : reverse (unLoc $3))
+           {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3))
                                      (mkLHsSigWcType $5)
                  ; addAnnotation (gl $1) AnnComma (gl $2)
-                 ; ams ( sLL $1 $> $ SigD sig )
+                 ; ams ( sLL $1 $> $ SigD noExt sig )
                        [mu AnnDcolon $4] } }
 
         | infix prec ops
-              {% ams (sLL $1 $> $ SigD
-                        (FixSig (FixitySig (fromOL $ unLoc $3)
+              {% ams (sLL $1 $> $ SigD noExt
+                        (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3)
                                 (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))
                      [mj AnnInfix $1,mj AnnVal $2] }
 
-        | pattern_synonym_sig   { sLL $1 $> . SigD . unLoc $ $1 }
+        | pattern_synonym_sig   { sLL $1 $> . SigD noExt . unLoc $ $1 }
 
         | '{-# COMPLETE' con_list opt_tyconsig  '#-}'
                 {% let (dcolon, tc) = $3
                    in ams
                        (sLL $1 $>
-                         (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc)))
+                         (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc)))
                     ([ mo $1 ] ++ dcolon ++ [mc $4]) }
 
         -- This rule is for both INLINE and INLINABLE pragmas
         | '{-# INLINE' activation qvar '#-}'
-                {% ams ((sLL $1 $> $ SigD (InlineSig $3
+                {% ams ((sLL $1 $> $ SigD noExt (InlineSig noExt $3
                             (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
                                             (snd $2)))))
                        ((mo $1:fst $2) ++ [mc $4]) }
 
         | '{-# SCC' qvar '#-}'
-          {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))
+          {% ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing)))
                  [mo $1, mc $3] }
 
         | '{-# SCC' qvar STRING '#-}'
           {% do { scc <- getSCC $3
                 ; let str_lit = StringLiteral (getSTRINGs $3) scc
-                ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
+                ; ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
                       [mo $1, mc $4] } }
 
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
              {% ams (
                  let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
-                                             (EmptyInlineSpec, FunLike) (snd $2)
-                  in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
+                                             (NoUserInline, FunLike) (snd $2)
+                  in sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) inl_prag))
                     (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
 
         | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-             {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
+             {% ams (sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5)
                                (mkInlinePragma (getSPEC_INLINE_PRAGs $1)
                                                (getSPEC_INLINE $1) (snd $2))))
                        (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
 
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                 {% ams (sLL $1 $>
-                                  $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))
+                                  $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs $1) $3))
                        [mo $1,mj AnnInstance $2,mc $4] }
 
         -- A minimal complete definition
         | '{-# MINIMAL' name_boolformula_opt '#-}'
-            {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))
+            {% ams (sLL $1 $> $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs $1) $2))
                    [mo $1,mc $3] }
 
 activation :: { ([AddAnn],Maybe Activation) }
@@ -2354,89 +2445,45 @@ quasiquote :: { Located (HsSplice GhcPs) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr GhcPs }
-        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3))
+        : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1)
                                        [mu AnnDcolon $2] }
-        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+        | infixexp '-<' exp     {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
                                                         HsFirstOrderApp True)
                                        [mu Annlarrowtail $2] }
-        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+        | infixexp '>-' exp     {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
                                                       HsFirstOrderApp False)
                                        [mu Annrarrowtail $2] }
-        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType
+        | infixexp '-<<' exp    {% ams (sLL $1 $> $ HsArrApp noExt $1 $3
                                                       HsHigherOrderApp True)
                                        [mu AnnLarrowtail $2] }
-        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType
+        | infixexp '>>-' exp    {% ams (sLL $1 $> $ HsArrApp noExt $3 $1
                                                       HsHigherOrderApp False)
                                        [mu AnnRarrowtail $2] }
         | infixexp              { $1 }
 
 infixexp :: { LHsExpr GhcPs }
         : exp10 { $1 }
-        | infixexp qop exp10  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+        | infixexp qop exp10  {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
                                      [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
 infixexp_top :: { LHsExpr GhcPs }
         : exp10_top               { $1 }
         | infixexp_top qop exp10_top
-                                  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+                                  {% ams (sLL $1 $> (OpApp noExt $1 $2 $3))
                                          [mj AnnVal $2] }
 
-exp10_top :: { LHsExpr GhcPs }
-        : '\\' apat apats opt_asig '->' exp
-                   {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
-                            [sLL $1 $> $ Match { m_ctxt = LambdaExpr
-                                               , m_pats = $2:$3
-                                               , m_type = snd $4
-                                               , m_grhss = unguardedGRHSs $6 }]))
-                          (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) }
 
-        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)
-                                               (mj AnnLet $1:mj AnnIn $3
-                                                 :(fst $ unLoc $2)) }
-        | '\\' 'lcase' altslist
-            {% ams (sLL $1 $> $ HsLamCase
-                                   (mkMatchGroup FromSource (snd $ unLoc $3)))
-                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
-        | 'if' exp optSemi 'then' exp optSemi 'else' exp
-                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
-                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)
-                                  (mj AnnIf $1:mj AnnThen $4
-                                     :mj AnnElse $7
-                                     :(map (\l -> mj AnnSemi l) (fst $3))
-                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }
-        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
-                                           ams (sLL $1 $> $ HsMultiIf
-                                                     placeHolderType
-                                                     (reverse $ snd $ unLoc $2))
-                                               (mj AnnIf $1:(fst $ unLoc $2)) }
-        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup
-                                                   FromSource (snd $ unLoc $4)))
-                                               (mj AnnCase $1:mj AnnOf $3
-                                                  :(fst $ unLoc $4)) }
-        | '-' fexp                      {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr)
+exp10_top :: { LHsExpr GhcPs }
+        : '-' fexp                      {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr)
                                                [mj AnnMinus $1] }
 
-        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
-                                               (mkHsDo DoExpr (snd $ unLoc $2)))
-                                               (mj AnnDo $1:(fst $ unLoc $2)) }
-        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
-                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
-                                           (mj AnnMdo $1:(fst $ unLoc $2)) }
 
-        | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
+        | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
                                                                 (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
                                       (fst $ fst $ fst $ unLoc $1) }
 
-        | 'proc' aexp '->' exp
-                       {% checkPattern empty $2 >>= \ p ->
-                           checkCommand $4 >>= \ cmd ->
-                           ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
-                                                placeHolderType []))
-                                            -- TODO: is LL right here?
-                               [mj AnnProc $1,mu AnnRarrow $3] }
-
-        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4)
+        | '{-# CORE' STRING '#-}' exp  {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
                                               [mo $1,mj AnnVal $2
                                               ,mc $3] }
                                           -- hdaume: core annotation
@@ -2444,7 +2491,7 @@ exp10_top :: { LHsExpr GhcPs }
 
 exp10 :: { LHsExpr GhcPs }
         : exp10_top            { $1 }
-        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
                                       (fst $ fst $ unLoc $1) }
 
 optSemi :: { ([Located a],Bool) }
@@ -2487,19 +2534,65 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
                                          }
 
 fexp    :: { LHsExpr GhcPs }
-        : fexp aexp                  { sLL $1 $> $ HsApp $1 $2 }
-        | fexp TYPEAPP atype         {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+        : fexp aexp                  {% checkBlockArguments $1 >> checkBlockArguments $2 >>
+                                        return (sLL $1 $> $ (HsApp noExt $1 $2)) }
+        | fexp TYPEAPP atype         {% checkBlockArguments $1 >>
+                                        ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1)
                                             [mj AnnAt $2] }
-        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic placeHolderNames $2)
+        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic noExt $2)
                                             [mj AnnStatic $1] }
         | aexp                       { $1 }
 
 aexp    :: { LHsExpr GhcPs }
-        : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
+        : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] }
             -- If you change the parsing, make sure to understand
             -- Note [Lexing type applications] in Lexer.x
 
-        | '~' aexp              {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
+        | '~' aexp              {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] }
+
+        | '\\' apat apats '->' exp
+                   {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource
+                            [sLL $1 $> $ Match { m_ext = noExt
+                                               , m_ctxt = LambdaExpr
+                                               , m_pats = $2:$3
+                                               , m_grhss = unguardedGRHSs $5 }]))
+                          [mj AnnLam $1, mu AnnRarrow $4] }
+        | 'let' binds 'in' exp          {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4)
+                                               (mj AnnLet $1:mj AnnIn $3
+                                                 :(fst $ unLoc $2)) }
+        | '\\' 'lcase' altslist
+            {% ams (sLL $1 $> $ HsLamCase noExt
+                                   (mkMatchGroup FromSource (snd $ unLoc $3)))
+                   (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
+        | 'if' exp optSemi 'then' exp optSemi 'else' exp
+                           {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >>
+                              ams (sLL $1 $> $ mkHsIf $2 $5 $8)
+                                  (mj AnnIf $1:mj AnnThen $4
+                                     :mj AnnElse $7
+                                     :(map (\l -> mj AnnSemi l) (fst $3))
+                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }
+        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>
+                                           ams (sLL $1 $> $ HsMultiIf noExt
+                                                     (reverse $ snd $ unLoc $2))
+                                               (mj AnnIf $1:(fst $ unLoc $2)) }
+        | 'case' exp 'of' altslist      {% ams (L (comb3 $1 $3 $4) $
+                                                   HsCase noExt $2 (mkMatchGroup
+                                                   FromSource (snd $ unLoc $4)))
+                                               (mj AnnCase $1:mj AnnOf $3
+                                                  :(fst $ unLoc $4)) }
+        | 'do' stmtlist              {% ams (L (comb2 $1 $2)
+                                               (mkHsDo DoExpr (snd $ unLoc $2)))
+                                               (mj AnnDo $1:(fst $ unLoc $2)) }
+        | 'mdo' stmtlist            {% ams (L (comb2 $1 $2)
+                                              (mkHsDo MDoExpr (snd $ unLoc $2)))
+                                           (mj AnnMdo $1:(fst $ unLoc $2)) }
+        | 'proc' aexp '->' exp
+                       {% checkPattern empty $2 >>= \ p ->
+                           checkCommand $4 >>= \ cmd ->
+                           ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd))
+                                            -- TODO: is LL right here?
+                               [mj AnnProc $1,mu AnnRarrow $3] }
+
         | aexp1                 { $1 }
 
 aexp1   :: { LHsExpr GhcPs }
@@ -2510,72 +2603,70 @@ aexp1   :: { LHsExpr GhcPs }
         | aexp2                { $1 }
 
 aexp2   :: { LHsExpr GhcPs }
-        : qvar                          { sL1 $1 (HsVar   $! $1) }
-        | qcon                          { sL1 $1 (HsVar   $! $1) }
-        | ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
-        | overloaded_label              { sL1 $1 (HsOverLabel Nothing $! unLoc $1) }
-        | literal                       { sL1 $1 (HsLit   $! unLoc $1) }
+        : qvar                          { sL1 $1 (HsVar noExt   $! $1) }
+        | qcon                          { sL1 $1 (HsVar noExt   $! $1) }
+        | ipvar                         { sL1 $1 (HsIPVar noExt $! unLoc $1) }
+        | overloaded_label              { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) }
+        | literal                       { sL1 $1 (HsLit noExt  $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -foverloaded-strings is on.
 --      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
---                                       (getSTRING $1) placeHolderType) }
-        | INTEGER   { sL (getLoc $1) (HsOverLit $! mkHsIntegral
-                                         (getINTEGER $1) placeHolderType) }
-        | RATIONAL  { sL (getLoc $1) (HsOverLit $! mkHsFractional
-                                          (getRATIONAL $1) placeHolderType) }
+--                                       (getSTRING $1) noExt) }
+        | INTEGER   { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral   (getINTEGER $1) ) }
+        | RATIONAL  { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) }
 
         -- N.B.: sections get parsed by these next two productions.
         -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
         -- correct Haskell (you'd have to write '((+ 3), (4 -))')
         -- but the less cluttered version fell out of having texps.
-        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] }
+        | '(' texp ')'                  {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] }
         | '(' tup_exprs ')'             {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2)
                                               ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } }
 
-        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple [L (gl $2)
-                                                         (Present $2)] Unboxed))
+        | '(#' texp '#)'                {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2)
+                                                         (Present noExt $2)] Unboxed))
                                                [mo $1,mc $3] }
         | '(#' tup_exprs '#)'           {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2)
                                               ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } }
 
         | '[' list ']'      {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) }
-        | '[:' parr ':]'    {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) }
-        | '_'               { sL1 $1 EWildPat }
+        | '_'               { sL1 $1 $ EWildPat noExt }
 
         -- Template Haskell Extension
         | splice_exp            { $1 }
 
-        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket (VarBr True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
-        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
-        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket (ExpBr $2))
+        | SIMPLEQUOTE  qvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE  qcon     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE tyvar     {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE gtycon    {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }
+        | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }
+        | '[|' exp '|]'       {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
                                                     else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }
-        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket (TExpBr $2))
+        | '[||' exp '||]'     {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2))
                                       (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }
-        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] }
+        | '[t|' ctype '|]'    {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] }
         | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
-                                      ams (sLL $1 $> $ HsBracket (PatBr p))
+                                      ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p))
                                           [mo $1,mu AnnCloseQ $3] }
-        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2)))
+        | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2)))
                                       (mo $1:mu AnnCloseQ $3:fst $2) }
-        | quasiquote          { sL1 $1 (HsSpliceE (unLoc $1)) }
+        | quasiquote          { sL1 $1 (HsSpliceE noExt (unLoc $1)) }
 
         -- arrow notation extension
-        | '(|' aexp2 cmdargs '|)'  {% ams (sLL $1 $> $ HsArrForm $2
+        | '(|' aexp2 cmdargs '|)'  {% ams (sLL $1 $> $ HsArrForm noExt $2
                                                            Nothing (reverse $3))
                                           [mu AnnOpenB $1,mu AnnCloseB $4] }
 
 splice_exp :: { LHsExpr GhcPs }
         : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE HasDollar
-                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                        (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
                                                            (getTH_ID_SPLICE $1)))))
                                        [mj AnnThIdSplice $1] }
         | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)
                                        [mj AnnOpenPE $1,mj AnnCloseP $3] }
         | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE HasDollar
-                                        (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
+                                        (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName
                                                         (getTH_ID_TY_SPLICE $1)))))
                                        [mj AnnThIdTySplice $1] }
         | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
@@ -2587,8 +2678,7 @@ cmdargs :: { [LHsCmdTop GhcPs] }
 
 acmd    :: { LHsCmdTop GhcPs }
         : aexp2                 {% checkCommand $1 >>= \ cmd ->
-                                    return (sL1 $1 $ HsCmdTop cmd
-                                           placeHolderType placeHolderType []) }
+                                    return (sL1 $1 $ HsCmdTop noExt cmd) }
 
 cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }
         :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1
@@ -2619,17 +2709,17 @@ texp :: { LHsExpr GhcPs }
         -- Then when converting expr to pattern we unravel it again
         -- Meanwhile, the renamer checks that real sections appear
         -- inside parens.
-        | infixexp qop        { sLL $1 $> $ SectionL $1 $2 }
-        | qopm infixexp       { sLL $1 $> $ SectionR $1 $2 }
+        | infixexp qop        { sLL $1 $> $ SectionL noExt $1 $2 }
+        | qopm infixexp       { sLL $1 $> $ SectionR noExt $1 $2 }
 
        -- View patterns get parenthesized above
-        | exp '->' texp   {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] }
+        | exp '->' texp   {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] }
 
 -- Always at least one comma or bar.
 tup_exprs :: { ([AddAnn],SumOrTuple) }
            : texp commas_tup_tail
                           {% do { addAnnotation (gl $1) AnnComma (fst $2)
-                                ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } }
+                                ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } }
 
            | texp bars    { (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }
 
@@ -2652,8 +2742,8 @@ commas_tup_tail : commas tup_tail
 -- Always follows a comma
 tup_tail :: { [LHsTupArg GhcPs] }
           : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >>
-                                    return ((L (gl $1) (Present $1)) : snd $2) }
-          | texp                 { [L (gl $1) (Present $1)] }
+                                    return ((L (gl $1) (Present noExt $1)) : snd $2) }
+          | texp                 { [L (gl $1) (Present noExt $1)] }
           | {- empty -}          { [noLoc missingTupArg] }
 
 -----------------------------------------------------------------------------
@@ -2662,19 +2752,18 @@ tup_tail :: { [LHsTupArg GhcPs] }
 -- The rules below are little bit contorted to keep lexps left-recursive while
 -- avoiding another shift/reduce-conflict.
 list :: { ([AddAnn],HsExpr GhcPs) }
-        : texp    { ([],ExplicitList placeHolderType Nothing [$1]) }
-        | lexps   { ([],ExplicitList placeHolderType Nothing
-                                                   (reverse (unLoc $1))) }
+        : texp    { ([],ExplicitList noExt Nothing [$1]) }
+        | lexps   { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) }
         | texp '..'             { ([mj AnnDotdot $2],
-                                      ArithSeq noPostTcExpr Nothing (From $1)) }
+                                      ArithSeq noExt Nothing (From $1)) }
         | texp ',' exp '..'     { ([mj AnnComma $2,mj AnnDotdot $4],
-                                  ArithSeq noPostTcExpr Nothing
+                                  ArithSeq noExt Nothing
                                                              (FromThen $1 $3)) }
         | texp '..' exp         { ([mj AnnDotdot $2],
-                                   ArithSeq noPostTcExpr Nothing
+                                   ArithSeq noExt Nothing
                                                                (FromTo $1 $3)) }
         | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4],
-                                    ArithSeq noPostTcExpr Nothing
+                                    ArithSeq noExt Nothing
                                                 (FromThenTo $1 $3 $5)) }
         | texp '|' flattenedpquals
              {% checkMonadComp >>= \ ctxt ->
@@ -2697,9 +2786,9 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
                     -- We just had one thing in our "parallel" list so
                     -- we simply return that thing directly
 
-                    qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+                    qss -> sL1 $1 [sL1 $1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr |
                                             qs <- qss]
-                                            noExpr noSyntaxExpr placeHolderType]
+                                            noExpr noSyntaxExpr]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
                 }
@@ -2746,29 +2835,6 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs
 -- in by choosing the "group by" variant, which is what we want.
 
 -----------------------------------------------------------------------------
--- Parallel array expressions
-
--- The rules below are little bit contorted; see the list case for details.
--- Note that, in contrast to lists, we only have finite arithmetic sequences.
--- Moreover, we allow explicit arrays with no element (represented by the nil
--- constructor in the list case).
-
-parr :: { ([AddAnn],HsExpr GhcPs) }
-        :                      { ([],ExplicitPArr placeHolderType []) }
-        | texp                 { ([],ExplicitPArr placeHolderType [$1]) }
-        | lexps                { ([],ExplicitPArr placeHolderType
-                                                          (reverse (unLoc $1))) }
-        | texp '..' exp        { ([mj AnnDotdot $2]
-                                 ,PArrSeq noPostTcExpr (FromTo $1 $3)) }
-        | texp ',' exp '..' exp
-                        { ([mj AnnComma $2,mj AnnDotdot $4]
-                          ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) }
-        | texp '|' flattenedpquals
-                        { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) }
-
--- We are reusing `lexps' and `flattenedpquals' from the list case.
-
------------------------------------------------------------------------------
 -- Guards
 
 guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
@@ -2788,7 +2854,7 @@ altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
                                                ,(reverse (snd $ unLoc $2))) }
         |     vocurly    alts  close { L (getLoc $2) (fst $ unLoc $2
                                         ,(reverse (snd $ unLoc $2))) }
-        | '{'                 '}'    { noLoc ([moc $1,mcc $2],[]) }
+        | '{'                 '}'    { sLL $1 $> ([moc $1,mcc $2],[]) }
         |     vocurly          close { noLoc ([],[]) }
 
 alts    :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
@@ -2812,15 +2878,15 @@ alts1   :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
         | alt                   { sL1 $1 ([],[$1]) }
 
 alt     :: { LMatch GhcPs (LHsExpr GhcPs) }
-        : pat opt_asig alt_rhs  {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt
-                                                        , m_pats = [$1]
-                                                        , m_type = snd $2
-                                                        , m_grhss = snd $ unLoc $3 }))
-                                      (fst $2 ++ (fst $ unLoc $3))}
+           : pat alt_rhs  {%ams (sLL $1 $> (Match { m_ext = noExt
+                                                  , m_ctxt = CaseAlt
+                                                  , m_pats = [$1]
+                                                  , m_grhss = snd $ unLoc $2 }))
+                                      (fst $ unLoc $2)}
 
 alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }
         : ralt wherebinds           { sLL $1 $> (fst $ unLoc $2,
-                                            GRHSs (unLoc $1) (snd $ unLoc $2)) }
+                                            GRHSs noExt (unLoc $1) (snd $ unLoc $2)) }
 
 ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }
         : '->' exp            {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))
@@ -2840,7 +2906,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }
 
 gdpat   :: { LGRHS GhcPs (LHsExpr GhcPs) }
         : '|' guardquals '->' exp
-                                  {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4)
+                                  {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4)
                                          [mj AnnVbar $1,mu AnnRarrow $3] }
 
 -- 'pat' recognises a pattern, including one with a bang at the top
@@ -2849,8 +2915,8 @@ gdpat   :: { LGRHS GhcPs (LHsExpr GhcPs) }
 -- we parse them right when bang-patterns are off
 pat     :: { LPat GhcPs }
 pat     :  exp          {% checkPattern empty $1 }
-        | '!' aexp      {% amms (checkPattern empty (sLL $1 $> (SectionR
-                                                     (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+        | '!' aexp      {% amms (checkPattern empty (sLL $1 $> (SectionR noExt
+                                                     (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
                                 [mj AnnBang $1] }
 
 bindpat :: { LPat GhcPs }
@@ -2858,14 +2924,14 @@ bindpat :  exp            {% checkPattern
                                 (text "Possibly caused by a missing 'do'?") $1 }
         | '!' aexp        {% amms (checkPattern
                                      (text "Possibly caused by a missing 'do'?")
-                                     (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                     (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
                                   [mj AnnBang $1] }
 
 apat   :: { LPat GhcPs }
 apat    : aexp                  {% checkPattern empty $1 }
         | '!' aexp              {% amms (checkPattern empty
-                                            (sLL $1 $> (SectionR
-                                                (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2)))
+                                            (sLL $1 $> (SectionR noExt
+                                                (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2)))
                                         [mj AnnBang $1] }
 
 apats  :: { [LPat GhcPs] }
@@ -2920,7 +2986,7 @@ qual  :: { LStmt GhcPs (LHsExpr GhcPs) }
     : bindpat '<-' exp                  {% ams (sLL $1 $> $ mkBindStmt $1 $3)
                                                [mu AnnLarrow $2] }
     | exp                               { sL1 $1 $ mkBodyStmt $1 }
-    | 'let' binds                       {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2))
+    | 'let' binds                       {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2))
                                                (mj AnnLet $1:(fst $ unLoc $2)) }
 
 -----------------------------------------------------------------------------
@@ -2962,7 +3028,7 @@ dbinds  :: { Located [LIPBind GhcPs] }
 --      | {- empty -}                  { [] }
 
 dbind   :: { LIPBind GhcPs }
-dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind (Left $1) $3))
+dbind   : ipvar '=' exp                {% ams (sLL $1 $> (IPBind noExt (Left $1) $3))
                                               [mj AnnEqual $2] }
 
 ipvar   :: { Located HsIPName }
@@ -3027,8 +3093,6 @@ gen_qcon :: { Located RdrName }
   | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))
                                    [mop $1,mj AnnVal $2,mcp $3] }
 
--- The case of '[:' ':]' is part of the production `parr'
-
 con     :: { Located RdrName }
         : conid                 { $1 }
         | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))
@@ -3088,9 +3152,6 @@ ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit
         | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName funTyCon)
                                        [mop $1,mu AnnRarrow $2,mcp $3] }
         | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }
-        | '[:' ':]'             {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] }
-        | '(' '~#' ')'          {% ams (sLL $1 $> $ getRdrName eqPrimTyCon)
-                                        [mop $1,mj AnnTildehsh $2,mcp $3] }
 
 oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;
                                 -- These can appear in export lists
@@ -3143,8 +3204,8 @@ qtycon :: { Located RdrName }   -- Qualified or unqualified
         | tycon             { $1 }
 
 qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified
-        : qtycon            { sL1 $1                     (HsTyVar NotPromoted $1)      }
-        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
+        : qtycon            { sL1 $1                           (HsTyVar noExt NotPromoted $1)      }
+        | qtycon docprev    { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) }
 
 tycon   :: { Located RdrName }  -- Unqualified
         : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
@@ -3177,15 +3238,19 @@ varop   :: { Located RdrName }
                                        ,mj AnnBackquote $3] }
 
 qop     :: { LHsExpr GhcPs }   -- used in sections
-        : qvarop                { sL1 $1 $ HsVar $1 }
-        | qconop                { sL1 $1 $ HsVar $1 }
-        | '`' '_' '`'           {% ams (sLL $1 $> EWildPat)
-                                       [mj AnnBackquote $1,mj AnnVal $2
-                                       ,mj AnnBackquote $3] }
+        : qvarop                { sL1 $1 $ HsVar noExt $1 }
+        | qconop                { sL1 $1 $ HsVar noExt $1 }
+        | hole_op               { $1 }
 
 qopm    :: { LHsExpr GhcPs }   -- used in sections
-        : qvaropm               { sL1 $1 $ HsVar $1 }
-        | qconop                { sL1 $1 $ HsVar $1 }
+        : qvaropm               { sL1 $1 $ HsVar noExt $1 }
+        | qconop                { sL1 $1 $ HsVar noExt $1 }
+        | hole_op               { $1 }
+
+hole_op :: { LHsExpr GhcPs }   -- used in sections
+hole_op : '`' '_' '`'           {% ams (sLL $1 $> $ EWildPat noExt)
+                                       [mj AnnBackquote $1,mj AnnVal $2
+                                       ,mj AnnBackquote $3] }
 
 qvarop :: { Located RdrName }
         : qvarsym               { $1 }
@@ -3298,6 +3363,7 @@ special_id
         | 'group'               { sL1 $1 (fsLit "group") }
         | 'stock'               { sL1 $1 (fsLit "stock") }
         | 'anyclass'            { sL1 $1 (fsLit "anyclass") }
+        | 'via'                 { sL1 $1 (fsLit "via") }
         | 'unit'                { sL1 $1 (fsLit "unit") }
         | 'dependency'          { sL1 $1 (fsLit "dependency") }
         | 'signature'           { sL1 $1 (fsLit "signature") }
@@ -3305,6 +3371,7 @@ special_id
 special_sym :: { Located FastString }
 special_sym : '!'       {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
             | '.'       { sL1 $1 (fsLit ".") }
+            | '*'       { sL1 $1 (fsLit (if isUnicode $1 then "\x2605" else "*")) }
 
 -----------------------------------------------------------------------------
 -- Data constructors
@@ -3331,19 +3398,19 @@ consym :: { Located RdrName }
 -- Literals
 
 literal :: { Located (HsLit GhcPs) }
-        : CHAR              { sL1 $1 $ HsChar       (sst $ getCHARs $1) $ getCHAR $1 }
-        | STRING            { sL1 $1 $ HsString     (sst $ getSTRINGs $1)
-                                                         $ getSTRING $1 }
-        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (sst $ getPRIMINTEGERs $1)
-                                                         $ getPRIMINTEGER $1 }
-        | PRIMWORD          { sL1 $1 $ HsWordPrim   (sst $ getPRIMWORDs $1)
-                                                         $ getPRIMWORD $1 }
-        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (sst $ getPRIMCHARs $1)
-                                                         $ getPRIMCHAR $1 }
-        | PRIMSTRING        { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1)
-                                                         $ getPRIMSTRING $1 }
-        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  def  $ getPRIMFLOAT $1 }
-        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim def  $ getPRIMDOUBLE $1 }
+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }
+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)
+                                                    $ getSTRING $1 }
+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)
+                                                    $ getPRIMINTEGER $1 }
+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)
+                                                    $ getPRIMWORD $1 }
+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)
+                                                    $ getPRIMCHAR $1 }
+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)
+                                                    $ getPRIMSTRING $1 }
+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExt $ getPRIMFLOAT $1 }
+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 }
 
 -----------------------------------------------------------------------------
 -- Layout
@@ -3379,24 +3446,24 @@ bars :: { ([SrcSpan],Int) }     -- One or more bars
 -- Documentation comments
 
 docnext :: { LHsDocString }
-  : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
+  : DOCNEXT {% return (sL1 $1 (mkHsDocString (getDOCNEXT $1))) }
 
 docprev :: { LHsDocString }
-  : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) }
+  : DOCPREV {% return (sL1 $1 (mkHsDocString (getDOCPREV $1))) }
 
 docnamed :: { Located (String, HsDocString) }
   : DOCNAMED {%
       let string = getDOCNAMED $1
           (name, rest) = break isSpace string
-      in return (sL1 $1 (name, HsDocString (mkFastString rest))) }
+      in return (sL1 $1 (name, mkHsDocString rest)) }
 
 docsection :: { Located (Int, HsDocString) }
   : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
-        return (sL1 $1 (n, HsDocString (mkFastString doc))) }
+        return (sL1 $1 (n, mkHsDocString doc)) }
 
 moduleheader :: { Maybe LHsDocString }
         : DOCNEXT {% let string = getDOCNEXT $1 in
-                     return (Just (sL1 $1 (HsDocString (mkFastString string)))) }
+                     return (Just (sL1 $1 (mkHsDocString string))) }
 
 maybe_docprev :: { Maybe LHsDocString }
         : docprev                       { Just $1 }
@@ -3464,9 +3531,6 @@ getCORE_PRAGs         (L _ (ITcore_prag         src)) = src
 getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src
 getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src
 getANN_PRAGs          (L _ (ITann_prag          src)) = src
-getVECT_PRAGs         (L _ (ITvect_prag         src)) = src
-getVECT_SCALAR_PRAGs  (L _ (ITvect_scalar_prag  src)) = src
-getNOVECT_PRAGs       (L _ (ITnovect_prag       src)) = src
 getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src
 getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src
 getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src
@@ -3490,6 +3554,7 @@ isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax
 isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax
+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax
 isUnicode _                           = False
 
 hasE :: Located Token -> Bool
@@ -3625,6 +3690,24 @@ hintExplicitForall' span = do
         , text "extension to enable explicit-forall syntax: forall <tvs>. <type>"
         ]
 
+-- When two single quotes don't followed by tyvar or gtycon, we report the
+-- error as empty character literal, or TH quote that missing proper type
+-- variable or constructor. See Trac #13450.
+reportEmptyDoubleQuotes :: SrcSpan -> P (GenLocated SrcSpan (HsExpr GhcPs))
+reportEmptyDoubleQuotes span = do
+    thEnabled <- liftM ((LangExt.TemplateHaskellQuotes `extopt`) . options) getPState
+    if thEnabled
+      then parseErrorSDoc span $ vcat
+        [ text "Parser error on `''`"
+        , text "Character literals may not be empty"
+        , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"
+        , text "but the type variable or constructor is missing"
+        ]
+      else parseErrorSDoc span $ vcat
+        [ text "Parser error on `''`"
+        , text "Character literals may not be empty"
+        ]
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -3740,7 +3823,4 @@ oll l =
 asl :: [Located a] -> Located b -> Located a -> P()
 asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls
 asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
-
-sst ::HasSourceText a => SourceText -> a
-sst = setSourceText
 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f2c8b33000..5784b9ecdb 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
 
 module   RdrHsSyn (
         mkHsOpApp,
@@ -41,8 +42,10 @@ module   RdrHsSyn (
 
         -- Bunch of functions in the parser monad for
         -- checking and constructing values
+        checkBlockArguments,
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
+        checkInfixConstr,
         checkPattern,         -- HsExp -> P HsPat
         bang_RDR,
         checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -52,8 +55,10 @@ module   RdrHsSyn (
         checkValSigLhs,
         checkDoAndIfThenElse,
         checkRecordSyntax,
-        parseErrorSDoc,
-        splitTilde, splitTildeApps,
+        checkEmptyGADTs,
+        parseErrorSDoc, hintBangPat,
+        splitTilde,
+        TyEl(..), mergeOps,
 
         -- Help with processing exports
         ImpExpSubSpec(..),
@@ -63,12 +68,16 @@ module   RdrHsSyn (
         mkImpExpSubSpec,
         checkImportSpec,
 
+        -- Warnings and errors
+        warnStarIsType,
+        failOpFewArgs,
+
         SumOrTuple (..), mkSumOrTuple
 
     ) where
 
+import GhcPrelude
 import HsSyn            -- Lots of it
-import Class            ( FunDep )
 import TyCon            ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )
 import DataCon          ( DataCon, dataConTyCon )
 import ConLike          ( ConLike(..) )
@@ -82,10 +91,9 @@ import Lexeme           ( isLexCon )
 import Type             ( TyThing(..) )
 import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
-                          listTyConName, listTyConKey,
-                          starKindTyConName, unicodeStarKindTyConName )
+                          listTyConName, listTyConKey, eqTyCon_RDR )
 import ForeignCall
-import PrelNames        ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
+import PrelNames        ( forall_tv_RDR, allNameStrings )
 import SrcLoc
 import Unique           ( hasKey )
 import OrdList          ( OrdList, fromOL )
@@ -95,9 +103,10 @@ import FastString
 import Maybes
 import Util
 import ApiAnnotation
+import HsExtension      ( noExt )
 import Data.List
 import qualified GHC.LanguageExtensions as LangExt
-import MonadUtils
+import DynFlags ( WarningFlag(..) )
 
 import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
@@ -124,15 +133,15 @@ import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
 
 --         *** See Note [The Naming story] in HsDecls ****
 
-mkTyClD :: LTyClDecl n -> LHsDecl n
-mkTyClD (L loc d) = L loc (TyClD d)
+mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)
+mkTyClD (L loc d) = L loc (TyClD noExt d)
 
-mkInstD :: LInstDecl n -> LHsDecl n
-mkInstD (L loc d) = L loc (InstD d)
+mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)
+mkInstD (L loc d) = L loc (InstD noExt d)
 
 mkClassDecl :: SrcSpan
             -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-            -> Located (a,[Located (FunDep (Located RdrName))])
+            -> Located (a,[LHsFunDep GhcPs])
             -> OrdList (LHsDecl GhcPs)
             -> P (LTyClDecl GhcPs)
 
@@ -143,13 +152,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams
        ; at_defs <- mapM (eitherToP . mkATDefault) at_insts
-       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
+       ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt
+                                  , tcdLName = cls, tcdTyVars = tyvars
                                   , tcdFixity = fixity
                                   , tcdFDs = snd (unLoc fds)
                                   , tcdSigs = mkClassOpSigs sigs
                                   , tcdMeths = binds
-                                  , tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs
-                                  , tcdFVs = placeHolderNames })) }
+                                  , tcdATs = ats, tcdATDefs = at_defs
+                                  , tcdDocs  = docs })) }
 
 mkATDefault :: LTyFamInstDecl GhcPs
             -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs)
@@ -159,14 +169,17 @@ mkATDefault :: LTyFamInstDecl GhcPs
 --
 -- We use the Either monad because this also called
 -- from Convert.hs
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
-      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
-                 , tfe_rhs = rhs } <- e
-      = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
-           ; return (L loc (TyFamEqn { tfe_tycon = tc
-                                     , tfe_pats = tvs
-                                     , tfe_fixity = fixity
-                                     , tfe_rhs = rhs })) }
+mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+      | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
+               , feqn_rhs = rhs } <- e
+      = do { tvs <- checkTyVars (text "default") equalsDots tc pats
+           ; return (L loc (FamEqn { feqn_ext    = noExt
+                                   , feqn_tycon  = tc
+                                   , feqn_pats   = tvs
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = rhs })) }
+mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault"
+mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault"
 
 mkTyData :: SrcSpan
          -> NewOrData
@@ -181,11 +194,10 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
+       ; return (L loc (DataDecl { tcdDExt = noExt,
+                                   tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
-                                   tcdDataDefn = defn,
-                                   tcdDataCusk = PlaceHolder,
-                                   tcdFVs = placeHolderNames })) }
+                                   tcdDataDefn = defn })) }
 
 mkDataDefn :: NewOrData
            -> Maybe (Located CType)
@@ -197,7 +209,8 @@ mkDataDefn :: NewOrData
 mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
-       ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+       ; return (HsDataDefn { dd_ext = noExt
+                            , dd_ND = new_or_data, dd_cType = cType
                             , dd_ctxt = cxt
                             , dd_cons = data_cons
                             , dd_kindSig = ksig
@@ -212,19 +225,22 @@ mkTySynonym loc lhs rhs
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams
-       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars
+       ; return (L loc (SynDecl { tcdSExt = noExt
+                                , tcdLName = tc, tcdTyVars = tyvars
                                 , tcdFixity = fixity
-                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
+                                , tcdRhs = rhs })) }
 
 mkTyFamInstEqn :: LHsType GhcPs
                -> LHsType GhcPs
                -> P (TyFamInstEqn GhcPs,[AddAnn])
 mkTyFamInstEqn lhs rhs
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
-       ; return (TyFamEqn { tfe_tycon = tc
-                          , tfe_pats  = mkHsImplicitBndrs tparams
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs },
+       ; return (mkHsImplicitBndrs
+                  (FamEqn { feqn_ext    = noExt
+                          , feqn_tycon  = tc
+                          , feqn_pats   = tparams
+                          , feqn_fixity = fixity
+                          , feqn_rhs    = rhs }),
                  ann) }
 
 mkDataFamInst :: SrcSpan
@@ -239,18 +255,18 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataFamInstD (
-                  DataFamInstDecl { dfid_tycon = tc
-                                  , dfid_pats = mkHsImplicitBndrs tparams
-                                  , dfid_fixity = fixity
-                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
+       ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs
+                  (FamEqn { feqn_ext    = noExt
+                          , feqn_tycon  = tc
+                          , feqn_pats   = tparams
+                          , feqn_fixity = fixity
+                          , feqn_rhs    = defn }))))) }
 
 mkTyFamInst :: SrcSpan
-            -> LTyFamInstEqn GhcPs
+            -> TyFamInstEqn GhcPs
             -> P (LInstDecl GhcPs)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
-                                             , tfid_fvs  = placeHolderNames })))
+  = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn)))
 
 mkFamDecl :: SrcSpan
           -> FamilyInfo GhcPs
@@ -262,7 +278,9 @@ mkFamDecl loc info lhs ksig injAnn
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams
-       ; return (L loc (FamDecl (FamilyDecl{ fdInfo      = info, fdLName = tc
+       ; return (L loc (FamDecl noExt (FamilyDecl
+                                           { fdExt       = noExt
+                                           , fdInfo      = info, fdLName = tc
                                            , fdTyVars    = tyvars
                                            , fdFixity    = fixity
                                            , fdResultSig = ksig
@@ -284,14 +302,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs
 -- Typed splices are not allowed at the top level, thus we do not represent them
 -- as spliced declaration.  See #10945
 mkSpliceDecl lexpr@(L loc expr)
-  | HsSpliceE splice@(HsUntypedSplice {}) <- expr
-  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr
+  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
 
-  | HsSpliceE splice@(HsQuasiQuote {}) <- expr
-  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr
+  = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice)
 
   | otherwise
-  = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
+  = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr))
+                              ImplicitSplice)
 
 mkRoleAnnotDecl :: SrcSpan
                 -> Located RdrName                -- type being annotated
@@ -299,7 +318,7 @@ mkRoleAnnotDecl :: SrcSpan
                 -> P (LRoleAnnotDecl GhcPs)
 mkRoleAnnotDecl loc tycon roles
   = do { roles' <- mapM parse_role roles
-       ; return $ L loc $ RoleAnnotDecl tycon roles' }
+       ; return $ L loc $ RoleAnnotDecl noExt tycon roles' }
   where
     role_data_type = dataTypeOf (undefined :: Role)
     all_roles = map fromConstr $ dataTypeConstrs role_data_type
@@ -337,17 +356,17 @@ cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]
 cvTopDecls decls = go (fromOL decls)
   where
     go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
-    go []                   = []
-    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
+    go []                     = []
+    go (L l (ValD x b) : ds)  = L l' (ValD x b') : go ds'
                             where (L l' b', ds') = getMonoBind (L l b) ds
-    go (d : ds)             = d : go ds
+    go (d : ds)               = d : go ds
 
 -- Declaration list may only contain value bindings and signatures.
 cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)
 cvBindGroup binding
   = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding
        ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
-         return $ ValBindsIn mbs sigs }
+         return $ ValBinds noExt mbs sigs }
 
 cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
   -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]
@@ -358,7 +377,7 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs)
 cvBindsAndSigs fb = go (fromOL fb)
   where
     go []              = return (emptyBag, [], [], [], [], [])
-    go (L l (ValD b) : ds)
+    go (L l (ValD _ b) : ds)
       = do { (bs, ss, ts, tfis, dfis, docs) <- go ds'
            ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) }
       where
@@ -366,17 +385,17 @@ cvBindsAndSigs fb = go (fromOL fb)
     go (L l decl : ds)
       = do { (bs, ss, ts, tfis, dfis, docs) <- go ds
            ; case decl of
-               SigD s
+               SigD _ s
                  -> return (bs, L l s : ss, ts, tfis, dfis, docs)
-               TyClD (FamDecl t)
+               TyClD _ (FamDecl _ t)
                  -> return (bs, ss, L l t : ts, tfis, dfis, docs)
-               InstD (TyFamInstD { tfid_inst = tfi })
+               InstD _ (TyFamInstD { tfid_inst = tfi })
                  -> return (bs, ss, ts, L l tfi : tfis, dfis, docs)
-               InstD (DataFamInstD { dfid_inst = dfi })
+               InstD _ (DataFamInstD { dfid_inst = dfi })
                  -> return (bs, ss, ts, tfis, L l dfi : dfis, docs)
-               DocD d
+               DocD _ d
                  -> return (bs, ss, ts, tfis, dfis, L l d : docs)
-               SpliceD d
+               SpliceD _ d
                  -> parseErrorSDoc l $
                     hang (text "Declaration splices are allowed only" <+>
                           text "at the top level:")
@@ -408,12 +427,12 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
   = go mtchs1 loc1 binds []
   where
     go mtchs loc
-       (L loc2 (ValD (FunBind { fun_id = L _ f2,
-                                fun_matches
-                                  = MG { mg_alts = L _ mtchs2 } })) : binds) _
+       (L loc2 (ValD _ (FunBind { fun_id = L _ f2,
+                                  fun_matches
+                                    = MG { mg_alts = L _ mtchs2 } })) : binds) _
         | f1 == f2 = go (mtchs2 ++ mtchs)
                         (combineSrcSpans loc loc2) binds []
-    go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
+    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls
         = let doc_decls' = doc_decl : doc_decls
           in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
     go mtchs loc binds doc_decls
@@ -425,12 +444,13 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
 getMonoBind bind binds = (bind, binds)
 
 has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool
-has_args []                           = panic "RdrHsSyn:has_args"
-has_args ((L _ (Match _ args _ _)) : _) = not (null args)
+has_args []                                    = panic "RdrHsSyn:has_args"
+has_args ((L _ (Match { m_pats = args })) : _) = not (null args)
         -- Don't group together FunBinds if they have
         -- no arguments.  This is necessary now that variable bindings
         -- with no arguments are now treated as FunBinds rather
         -- than pattern bindings (tests/rename/should_fail/rnfail002).
+has_args ((L _ (XMatch _)) : _) = panic "has_args"
 
 {- **********************************************************************
 
@@ -452,7 +472,8 @@ So the plan is:
 
 * Parse the data constructor declration as a type (actually btype_no_ops)
 
-* Use 'splitCon' to rejig it into the data constructor and the args
+* Use 'splitCon' to rejig it into the data constructor, the args, and possibly
+  extract a docstring for the constructor
 
 * In doing so, we use 'tyConToDataCon' to convert the RdrName for
   the data con, which has been parsed as a tycon, back to a datacon.
@@ -461,28 +482,58 @@ So the plan is:
      data T = (+++)
   will parse ok (since tycons can be operators), but we should reject
   it (Trac #12051).
+
+'splitCon' takes a reversed list @apps@ of types as input, such that
+@foldl1 mkHsAppTy (reverse apps)@ yields the original type. This is because
+this is easy for the parser to produce and we avoid the overhead of unrolling
+'HsAppTy'.
+
 -}
 
-splitCon :: LHsType GhcPs
-      -> P (Located RdrName, HsConDeclDetails GhcPs)
+splitCon :: [LHsType GhcPs]
+      -> P ( Located RdrName         -- constructor name
+           , HsConDeclDetails GhcPs  -- constructor field information
+           , Maybe LHsDocString      -- docstring to go on the constructor
+           )
 -- See Note [Parsing data constructors is hard]
 -- This gets given a "type" that should look like
 --      C Int Bool
 -- or   C { x::Int, y::Bool }
 -- and returns the pieces
-splitCon ty
- = split ty []
+splitCon apps
+ = split apps' []
  where
-   -- This is used somewhere where HsAppsTy is not used
-   split (L _ (HsAppTy t u)) ts       = split t (u : ts)
-   split (L l (HsTyVar _ (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
-                                             return (data_con, mk_rest ts)
-   split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
-      = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
-   split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
-
-   mk_rest [L l (HsRecTy flds)] = RecCon (L l flds)
-   mk_rest ts                   = PrefixCon ts
+   oneDoc = [ () | L _ (HsDocTy{}) <- apps ] `lengthIs` 1
+   ty = foldl1 mkHsAppTy (reverse apps)
+
+   -- the trailing doc, if any, can be extracted first
+   (apps', trailing_doc)
+     = case apps of
+         L _ (HsDocTy _ t ds) : ts | oneDoc -> (t : ts, Just ds)
+         ts -> (ts, Nothing)
+
+   -- A comment on the constructor is handled a bit differently - it doesn't
+   -- remain an 'HsDocTy', but gets lifted out and returned as the third
+   -- element of the tuple.
+   split [ L _ (HsDocTy _ con con_doc) ] ts = do
+     (data_con, con_details, con_doc') <- split [con] ts
+     return (data_con, con_details, con_doc' `mplus` Just con_doc)
+   split [ L l (HsTyVar _ _ (L _ tc)) ] ts = do
+     data_con <- tyConToDataCon l tc
+     return (data_con, mk_rest ts, trailing_doc)
+   split [ L l (HsTupleTy _ HsBoxedOrConstraintTuple ts) ] []
+     = return ( L l (getRdrName (tupleDataCon Boxed (length ts)))
+              , PrefixCon ts
+              , trailing_doc
+              )
+   split [ L l _ ] _ = parseErrorSDoc l (text msg <+> ppr ty)
+     where msg = "Cannot parse data constructor in a data/newtype declaration:"
+   split (u : us) ts = split us (u : ts)
+   split _ _ = panic "RdrHsSyn:splitCon"
+
+   mk_rest [L _ (HsDocTy _ t@(L _ HsRecTy{}) _)] = mk_rest [t]
+   mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds)
+   mk_rest ts                     = PrefixCon ts
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 -- See Note [Parsing data constructors is hard]
@@ -502,6 +553,22 @@ tyConToDataCon loc tc
           = text "Perhaps you intended to use ExistentialQuantification"
           | otherwise = empty
 
+-- | Split a type to extract the trailing doc string (if there is one) from a
+-- type produced by the 'btype_no_ops' production.
+splitDocTy :: LHsType GhcPs -> (LHsType GhcPs, Maybe LHsDocString)
+splitDocTy (L l (HsAppTy x t1 t2)) = (L l (HsAppTy x t1 t2'), ds)
+  where ~(t2', ds) = splitDocTy t2
+splitDocTy (L _ (HsDocTy _ ty ds)) = (ty, Just ds)
+splitDocTy ty = (ty, Nothing)
+
+-- | Given a type that is a field to an infix data constructor, try to split
+-- off a trailing docstring on the type, and check that there are no other
+-- docstrings.
+checkInfixConstr :: LHsType GhcPs -> P (LHsType GhcPs, Maybe LHsDocString)
+checkInfixConstr ty = checkNoDocs msg ty' *> pure (ty', doc_string)
+  where (ty', doc_string) = splitDocTy ty
+        msg = text "infix constructor field"
+
 mkPatSynMatchGroup :: Located RdrName
                    -> Located (OrdList (LHsDecl GhcPs))
                    -> P (MatchGroup GhcPs (LHsExpr GhcPs))
@@ -510,14 +577,25 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
        ; when (null matches) (wrongNumberErr loc)
        ; return $ mkMatchGroup FromSource matches }
   where
-    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
+    fromDecl (L loc decl@(ValD _ (PatBind _
+                                   pat@(L _ (ConPatIn ln@(L _ name) details))
+                                   rhs _))) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
-               PrefixCon pats ->
-                        return $ Match (FunRhs ln Prefix NoSrcStrict) pats Nothing rhs
-               InfixCon pat1 pat2 ->
-                       return $ Match (FunRhs ln Infix NoSrcStrict) [pat1, pat2] Nothing rhs
+               PrefixCon pats -> return $ Match { m_ext = noExt
+                                                , m_ctxt = ctxt, m_pats = pats
+                                                , m_grhss = rhs }
+                   where
+                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict }
+
+               InfixCon p1 p2 -> return $ Match { m_ext = noExt
+                                                , m_ctxt = ctxt
+                                                , m_pats = [p1, p2]
+                                                , m_grhss = rhs }
+                   where
+                     ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict }
+
                RecCon{} -> recordPatSynErr loc pat
            ; return $ L loc match }
     fromDecl (L loc decl) = extraDeclErr loc decl
@@ -544,24 +622,76 @@ recordPatSynErr loc pat =
     ppr pat
 
 mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs]
-                -> LHsContext GhcPs -> HsConDeclDetails GhcPs
+                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
                 -> ConDecl GhcPs
 
-mkConDeclH98 name mb_forall cxt details
-  = ConDeclH98 { con_name     = name
-               , con_qvars    = fmap mkHsQTvs mb_forall
-               , con_cxt      = Just cxt
-                             -- AZ:TODO: when can cxt be Nothing?
-                             --          remembering that () is a valid context.
-               , con_details  = details
-               , con_doc      = Nothing }
+mkConDeclH98 name mb_forall mb_cxt args
+  = ConDeclH98 { con_ext    = noExt
+               , con_name   = name
+               , con_forall = noLoc $ isJust mb_forall
+               , con_ex_tvs = mb_forall `orElse` []
+               , con_mb_cxt = mb_cxt
+               , con_args   = args'
+               , con_doc    = Nothing }
+  where
+    args' = nudgeHsSrcBangs args
 
 mkGadtDecl :: [Located RdrName]
-           -> LHsSigType GhcPs     -- Always a HsForAllTy
-           -> ConDecl GhcPs
-mkGadtDecl names ty = ConDeclGADT { con_names = names
-                                  , con_type  = ty
-                                  , con_doc   = Nothing }
+           -> LHsType GhcPs     -- Always a HsForAllTy
+           -> (ConDecl GhcPs, [AddAnn])
+mkGadtDecl names ty
+  = (ConDeclGADT { con_g_ext  = noExt
+                 , con_names  = names
+                 , con_forall = L l $ isLHsForAllTy ty'
+                 , con_qvars  = mkHsQTvs tvs
+                 , con_mb_cxt = mcxt
+                 , con_args   = args'
+                 , con_res_ty = res_ty
+                 , con_doc    = Nothing }
+    , anns1 ++ anns2)
+  where
+    (ty'@(L l _),anns1) = peel_parens ty []
+    (tvs, rho) = splitLHsForAllTy ty'
+    (mcxt, tau, anns2) = split_rho rho []
+
+    split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann
+                                       = (Just cxt, tau, ann)
+    split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l)
+    split_rho tau                  ann = (Nothing, tau, ann)
+
+    (args, res_ty) = split_tau tau
+    args' = nudgeHsSrcBangs args
+
+    -- See Note [GADT abstract syntax] in HsDecls
+    split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty))
+                                   = (RecCon (L loc rf), res_ty)
+    split_tau tau                  = (PrefixCon [], tau)
+
+    peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty
+                                                       (ann++mkParensApiAnn l)
+    peel_parens ty                   ann = (ty, ann)
+
+nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
+-- ^ This function ensures that fields with strictness or packedness
+-- annotations put these annotations on an outer 'HsBangTy'.
+--
+-- The problem is that in the parser, strictness and packedness annotations
+-- bind more tightly that docstrings. However, the expectation downstream of
+-- the parser (by functions such as 'getBangType' and 'getBangStrictness')
+-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the
+-- top-level type.
+--
+-- See #15206
+nudgeHsSrcBangs details
+  = case details of
+      PrefixCon as -> PrefixCon (map go as)
+      RecCon r -> RecCon r
+      InfixCon a1 a2 -> InfixCon (go a1) (go a2)
+  where
+    go (L l (HsDocTy _ (L _ (HsBangTy _ s lty)) lds)) =
+      L l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds)))
+    go lty = lty
+
 
 setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 -- ^ This rather gruesome function is used mainly by the parser.
@@ -648,23 +778,6 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It
 really doesn't matter!
 -}
 
--- | Note [Sorting out the result type]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a GADT declaration which is not a record, we put the whole constr type
--- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
--- it has sorted out operator fixities. Consider for example
---      C :: a :*: b -> a :*: b -> a :+: b
--- Initially this type will parse as
---       a :*: (b -> (a :*: (b -> (a :+: b))))
---
--- so it's hard to split up the arguments until we've done the precedence
--- resolution (in the renamer). On the other hand, for a record
---         { x,y :: Int } -> a :*: b
--- there is no doubt.  AND we need to sort records out so that
--- we can bring x,y into scope.  So:
---    * For PrefixCon we keep all the args in the res_ty
---    * For RecCon we do not
-
 checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs]
              -> P (LHsQTyVars GhcPs)
 -- Same as checkTyVars, but in the P monad
@@ -686,16 +799,13 @@ checkTyVars pp_what equals_or_where tc tparms
   = do { tvs <- mapM chk tparms
        ; return (mkHsQTvs tvs) }
   where
-
-    chk (L _ (HsParTy ty)) = chk ty
-    chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
+    chk (L _ (HsParTy _ ty)) = chk ty
 
         -- Check that the name space is correct!
-    chk (L l (HsKindSig
-            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
-    chk (L l (HsTyVar _ (L ltv tv)))
-        | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
+    chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))
+        | isRdrTyVar tv    = return (L l (KindedTyVar noExt (L lv tv) k))
+    chk (L l (HsTyVar _ _ (L ltv tv)))
+        | isRdrTyVar tv    = return (L l (UserTyVar noExt (L ltv tv)))
     chk t@(L loc _)
         = Left (loc,
                 vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -728,6 +838,21 @@ checkRecordSyntax lr@(L loc r)
                       (text "Illegal record syntax (use TraditionalRecordSyntax):" <+>
                        ppr r)
 
+-- | Check if the gadt_constrlist is empty. Only raise parse error for
+-- `data T where` to avoid affecting existing error message, see #8258.
+checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])
+                -> P (Located ([AddAnn], [LConDecl GhcPs]))
+checkEmptyGADTs gadts@(L span (_, []))               -- Empty GADT declaration.
+    = do opts <- fmap options getPState
+         if LangExt.GADTSyntax `extopt` opts         -- GADTs implies GADTSyntax
+            then return gadts
+            else parseErrorSDoc span $ vcat
+              [ text "Illegal keyword 'where' in data declaration"
+              , text "Perhaps you intended to use GADTs or a similar language"
+              , text "extension to enable syntax: data T where"
+              ]
+checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.
+
 checkTyClHdr :: Bool               -- True  <=> class header
                                    -- False <=> type header
              -> LHsType GhcPs
@@ -744,23 +869,20 @@ checkTyClHdr is_cls ty
   where
     goL (L l ty) acc ann fix = go l ty acc ann fix
 
-    go l (HsTyVar _ (L _ tc)) acc ann fix
+    -- workaround to define '*' despite StarIsType
+    go _ (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix
+      = do { warnStarBndr l
+           ; let name = mkOccName tcClsName (if isUni then "★" else "*")
+           ; return (L l (Unqual name), acc, fix, ann) }
+
+    go l (HsTyVar _ _ (L _ tc)) acc ann fix
       | isRdrTc tc               = return (L l tc, acc, fix, ann)
-    go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix
+    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
       | isRdrTc tc               = return (ltc, t1:t2:acc, Infix, ann)
-    go l (HsParTy ty)    acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix
-    go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
-    go _ (HsAppsTy ts)   acc ann _fix
-      | Just (head, args, fixity) <- getAppsTyHead_maybe ts
-      = goL head (args ++ acc) ann fixity
-
-    go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix
-      | isStar star
-      = return (L loc (nameRdrName starKindTyConName), [], fix, ann)
-      | isUniStar star
-      = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann)
-
-    go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix
+    go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix
+    go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix
+
+    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
       = return (L l (nameRdrName tup_name), ts, fix, ann)
       where
         arity = length ts
@@ -771,24 +893,68 @@ checkTyClHdr is_cls ty
       = parseErrorSDoc l (text "Malformed head of type or class declaration:"
                           <+> ppr ty)
 
+-- | Yield a parse error if we have a function applied directly to a do block
+-- etc. and BlockArguments is not enabled.
+checkBlockArguments :: LHsExpr GhcPs -> P ()
+checkBlockArguments expr = case unLoc expr of
+    HsDo _ DoExpr _ -> check "do block"
+    HsDo _ MDoExpr _ -> check "mdo block"
+    HsLam {} -> check "lambda expression"
+    HsCase {} -> check "case expression"
+    HsLamCase {} -> check "lambda-case expression"
+    HsLet {} -> check "let expression"
+    HsIf {} -> check "if expression"
+    HsProc {} -> check "proc expression"
+    _ -> return ()
+  where
+    check element = do
+      pState <- getPState
+      unless (extopt LangExt.BlockArguments (options pState)) $
+        parseErrorSDoc (getLoc expr) $
+          text "Unexpected " <> text element <> text " in function application:"
+           $$ nest 4 (ppr expr)
+           $$ text "You could write it with parentheses"
+           $$ text "Or perhaps you meant to enable BlockArguments?"
+
+-- | Validate the context constraints and break up a context into a list
+-- of predicates.
+--
+-- @
+--     (Eq a, Ord b)        -->  [Eq a, Ord b]
+--     Eq a                 -->  [Eq a]
+--     (Eq a)               -->  [Eq a]
+--     (((Eq a)))           -->  [Eq a]
+-- @
 checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
 checkContext (L l orig_t)
   = check [] (L l orig_t)
  where
-  check anns (L lp (HsTupleTy _ ts))   -- (Eq a, Ord b) shows up as a tuple type
+  check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))
+    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
+    -- be used as context constraints.
     = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()
 
-    -- don't let HsAppsTy get in the way
-  check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
-    = check anns ty
-
-  check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
+  check anns (L lp1 (HsParTy _ ty))
+                                  -- to be sure HsParTy doesn't get into the way
        = check anns' ty
          where anns' = if l == lp1 then anns
                                    else (anns ++ mkParensApiAnn lp1)
 
-  check _anns _
-    = return ([],L l [L l orig_t]) -- no need for anns, returning original
+  -- no need for anns, returning original
+  check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t])
+
+  msg = text "data constructor context"
+
+-- | Check recursively if there are any 'HsDocTy's in the given type.
+-- This only works on a subset of types produced by 'btype_no_ops'
+checkNoDocs :: SDoc -> LHsType GhcPs -> P ()
+checkNoDocs msg ty = go ty
+  where
+    go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2
+    go (L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep
+                                  [ text "Unexpected haddock", quotes (ppr ds)
+                                  , text "on", msg, quotes (ppr t) ]
+    go _ = pure ()
 
 -- -------------------------------------------------------------------------
 -- Checking Patterns.
@@ -807,7 +973,7 @@ checkLPat msg e@(L l _) = checkPat msg l e []
 
 checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
          -> P (LPat GhcPs)
-checkPat _ loc (L l e@(HsVar (L _ c))) args
+checkPat _ loc (L l e@(HsVar _ (L _ c))) args
   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
   | not (null args) && patIsRec c =
       patFail (text "Perhaps you intended to use RecursiveDo") l e
@@ -817,7 +983,7 @@ checkPat msg loc e args     -- OK to let this happen even if bang-patterns
   | Just (e', args') <- splitBang e
   = do  { args'' <- checkPatterns msg args'
         ; checkPat msg loc e' (args'' ++ args) }
-checkPat msg loc (L _ (HsApp f e)) args
+checkPat msg loc (L _ (HsApp _ f e)) args
   = do p <- checkLPat msg e
        checkPat msg loc f (p : args)
 checkPat msg loc (L _ e) []
@@ -831,76 +997,75 @@ checkAPat msg loc e0 = do
  pState <- getPState
  let opts = options pState
  case e0 of
-   EWildPat -> return (WildPat placeHolderType)
-   HsVar x  -> return (VarPat x)
-   HsLit (HsStringPrim _ _) -- (#13260)
+   EWildPat _ -> return (WildPat noExt)
+   HsVar _ x  -> return (VarPat noExt x)
+   HsLit _ (HsStringPrim _ _) -- (#13260)
        -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0)
 
-   HsLit l  -> return (LitPat l)
+   HsLit _ l  -> return (LitPat noExt l)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
    -- NB. Negative *primitive* literals are already handled by the lexer
-   HsOverLit pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
-   NegApp (L l (HsOverLit pos_lit)) _
+   HsOverLit _ pos_lit          -> return (mkNPat (L loc pos_lit) Nothing)
+   NegApp _ (L l (HsOverLit _ pos_lit)) _
                         -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr))
 
-   SectionR (L lb (HsVar (L _ bang))) e    -- (! x)
+   SectionR _ (L lb (HsVar _ (L _ bang))) e    -- (! x)
         | bang == bang_RDR
-        -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then do { e' <- checkLPat msg e
-                                   ; addAnnotation loc AnnBang lb
-                                   ; return  (BangPat e') }
-                else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) }
-
-   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
-   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
+        -> do { hintBangPat loc e0
+              ; e' <- checkLPat msg e
+              ; addAnnotation loc AnnBang lb
+              ; return  (BangPat noExt e') }
+
+   ELazyPat _ e         -> checkLPat msg e >>= (return . (LazyPat noExt))
+   EAsPat _ n e         -> checkLPat msg e >>= (return . (AsPat noExt) n)
    -- view pattern is well-formed if the pattern is
-   EViewPat expr patE  -> checkLPat msg patE >>=
-                            (return . (\p -> ViewPat expr p placeHolderType))
-   ExprWithTySig e t   -> do e <- checkLPat msg e
-                             return (SigPatIn e t)
+   EViewPat _ expr patE -> checkLPat msg patE >>=
+                            (return . (\p -> ViewPat noExt expr p))
+   ExprWithTySig t e   -> do e <- checkLPat msg e
+                             return (SigPat t e)
 
    -- n+k patterns
-   OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
-         (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
+   OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus)))
+           (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
                       | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
-   OpApp l op _fix r  -> do l <- checkLPat msg l
-                            r <- checkLPat msg r
-                            case op of
-                               L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c)
-                                      -> return (ConPatIn (L cl c) (InfixCon l r))
-                               _ -> patFail msg loc e0
+   OpApp _ l (L cl (HsVar _ (L _ c))) r
+     | isDataOcc (rdrNameOcc c) -> do
+         l <- checkLPat msg l
+         r <- checkLPat msg r
+         return (ConPatIn (L cl c) (InfixCon l r))
+
+   OpApp {}           -> patFail msg loc e0
 
-   HsPar e            -> checkLPat msg e >>= (return . ParPat)
-   ExplicitList _ _ es  -> do ps <- mapM (checkLPat msg) es
-                              return (ListPat ps placeHolderType Nothing)
-   ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es
-                            return (PArrPat ps placeHolderType)
+   ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
+                             return (ListPat noExt ps)
 
-   ExplicitTuple es b
+   HsPar _ e          -> checkLPat msg e >>= (return . (ParPat noExt))
+
+   ExplicitTuple _ es b
      | all tupArgPresent es  -> do ps <- mapM (checkLPat msg)
-                                              [e | L _ (Present e) <- es]
-                                   return (TuplePat ps b [])
+                                              [e | L _ (Present _ e) <- es]
+                                   return (TuplePat noExt ps b)
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
-   ExplicitSum alt arity expr _ -> do
+   ExplicitSum _ alt arity expr -> do
      p <- checkLPat msg expr
-     return (SumPat p alt arity placeHolderType)
+     return (SumPat noExt p alt arity)
 
    RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
                         -> do fs <- mapM (checkPatField msg) fs
                               return (ConPatIn c (RecCon (HsRecFields fs dd)))
-   HsSpliceE s | not (isTypedSplice s)
-               -> return (SplicePat s)
+   HsSpliceE _ s | not (isTypedSplice s)
+               -> return (SplicePat noExt s)
    _           -> patFail msg loc e0
 
 placeHolderPunRhs :: LHsExpr GhcPs
 -- The RHS of a punned record field will be filled in by the renamer
 -- It's better not to make it an error, in case we want to print it when debugging
-placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR))
+placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
 
 plus_RDR, bang_RDR, pun_RDR :: RdrName
 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -934,14 +1099,14 @@ checkValDef :: SDoc
 checkValDef msg _strictness lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
   = checkPatBind msg (L (combineLocs lhs sig)
-                        (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
+                        (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss
 
-checkValDef msg strictness lhs opt_sig g@(L l (_,grhss))
+checkValDef msg strictness lhs Nothing g@(L l (_,grhss))
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
             Just (fun, is_infix, pats, ann) ->
               checkFunBind msg strictness ann (getLoc lhs)
-                           fun is_infix pats opt_sig (L l grhss)
+                           fun is_infix pats (L l grhss)
             Nothing -> checkPatBind msg lhs g }
 
 checkFunBind :: SDoc
@@ -951,18 +1116,19 @@ checkFunBind :: SDoc
              -> Located RdrName
              -> LexicalFixity
              -> [LHsExpr GhcPs]
-             -> Maybe (LHsType GhcPs)
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
-checkFunBind msg strictness ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
   = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
         return (ann, makeFunBind fun
-                  [L match_span (Match { m_ctxt = FunRhs fun is_infix strictness
+                  [L match_span (Match { m_ext = noExt
+                                       , m_ctxt = FunRhs { mc_fun    = fun
+                                                         , mc_fixity = is_infix
+                                                         , mc_strictness = strictness }
                                        , m_pats = ps
-                                       , m_type = opt_sig
                                        , m_grhss = grhss })])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
@@ -971,10 +1137,10 @@ makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn ms
-  = FunBind { fun_id = fn,
+  = FunBind { fun_ext = noExt,
+              fun_id = fn,
               fun_matches = mkMatchGroup FromSource ms,
               fun_co_fn = idHsWrapper,
-              bind_fvs = placeHolderNames,
               fun_tick = [] }
 
 checkPatBind :: SDoc
@@ -983,11 +1149,11 @@ checkPatBind :: SDoc
              -> P ([AddAnn],HsBind GhcPs)
 checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
-        ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
+        ; return ([],PatBind noExt lhs grhss
                     ([],[])) }
 
 checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
-checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
   | isUnqual v
   , not (isDataOcc (rdrNameOcc v))
   = return lrdr
@@ -1009,9 +1175,9 @@ checkValSigLhs lhs@(L l _)
     -- A common error is to forget the ForeignFunctionInterface flag
     -- so check for that, and suggest.  cf Trac #3805
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
-    looks_like s (L _ (HsVar (L _ v))) = v == s
-    looks_like s (L _ (HsApp lhs _))   = looks_like s lhs
-    looks_like _ _                     = False
+    looks_like s (L _ (HsVar _ (L _ v))) = v == s
+    looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs
+    looks_like _ _                       = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
     default_RDR = mkUnqual varName (fsLit "default")
@@ -1044,13 +1210,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
         -- not be any OpApps inside the e's
 splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
 -- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg))
-  | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns)
+splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg))
+  | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns)
   where
     l' = combineLocs bang arg1
     (arg1,argns) = split_bang r_arg []
-    split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
-    split_bang e                 es = (e,es)
+    split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es)
+    split_bang e                   es = (e,es)
 splitBang _ = Nothing
 
 isFunLhs :: LHsExpr GhcPs
@@ -1069,14 +1235,15 @@ isFunLhs :: LHsExpr GhcPs
 
 isFunLhs e = go e [] []
  where
-   go (L loc (HsVar (L _ f))) es ann
-        | not (isRdrDataCon f)       = return (Just (L loc f, Prefix, es, ann))
-   go (L _ (HsApp f e)) es       ann = go f (e:es) ann
-   go (L l (HsPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
+   go (L loc (HsVar _ (L _ f))) es ann
+        | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, ann))
+   go (L _ (HsApp _ f e)) es       ann = go f (e:es) ann
+   go (L l (HsPar _ e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
 
         -- Things of the form `!x` are also FunBinds
-        -- See Note [Varieties of binding pattern matches]
-   go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann
+        -- See Note [FunBind vs PatBind]
+   go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var)))))
+                                                                         [] ann
         | bang == bang_RDR
         , not (isRdrDataCon var)     = return (Just (L l var, Prefix, [], ann))
 
@@ -1093,7 +1260,7 @@ isFunLhs e = go e [] []
         -- ToDo: what about this?
         --              x + 1 `op` y = ...
 
-   go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann
+   go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann
         | Just (e',es') <- splitBang e
         = do { bang_on <- extension bangPatEnabled
              ; if bang_on then go e' (es' ++ es) ann
@@ -1107,59 +1274,83 @@ isFunLhs e = go e [] []
                  Just (op', Infix, j : k : es', ann')
                    -> return (Just (op', Infix, j : op_app : es', ann'))
                    where
-                     op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r)
+                     op_app = L loc (OpApp noExt k
+                                       (L loc' (HsVar noExt (L loc' op))) r)
                  _ -> return Nothing }
    go _ _ _ = return Nothing
 
-
--- | Transform btype_no_ops with strict_mark's into HsEqTy's
--- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
-splitTilde :: LHsType GhcPs -> P (LHsType GhcPs)
-splitTilde t = go t
-  where go (L loc (HsAppTy t1 t2))
-          | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
-                                                                          <- t2
-          = do
-              moveAnnotations lo loc
-              t1' <- go t1
-              return (L loc (HsEqTy t1' t2'))
-          | otherwise
-          = do
-              t1' <- go t1
-              case t1' of
-                (L lo (HsEqTy tl tr)) -> do
-                  let lr = combineLocs tr t2
-                  moveAnnotations lo loc
-                  return (L loc (HsEqTy tl (L lr (HsAppTy tr t2))))
-                t -> do
-                  return (L loc (HsAppTy t t2))
-
-        go t = return t
-
-
--- | Transform tyapps with strict_marks into uses of twiddle
--- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
-splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs]
-splitTildeApps []         = return []
-splitTildeApps (t : rest) = do
-  rest' <- concatMapM go rest
-  return (t : rest')
-  where go (L l (HsAppPrefix
-            (L loc (HsBangTy
-                    (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
-                    ty))))
-          = addAnnotation l AnnTilde tilde_loc >>
-            return
-              [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
-               L l (HsAppPrefix ty)]
-               -- NOTE: no annotation is attached to an HsAppPrefix, so the
-               --       surrounding SrcSpan is not critical
-          where
-            tilde_loc = srcSpanFirstCharacter loc
-
-        go t = return [t]
-
-
+-- | Transform a list of 'atype' with 'strict_mark' into
+-- HsOpTy's of 'eqTyCon_RDR':
+--
+--   [~a, ~b, c, ~d] ==> (~a) ~ ((b c) ~ d)
+--
+-- See Note [Parsing ~]
+splitTilde :: [LHsType GhcPs] -> P (LHsType GhcPs)
+splitTilde [] = panic "splitTilde"
+splitTilde (x:xs) = go x xs
+  where
+    -- We accumulate applications in the LHS until we encounter a laziness
+    -- annotation. For example, if we have [Foo, x, y, ~Bar, z], the 'lhs'
+    -- accumulator will become '(Foo x) y'. Then we strip the laziness
+    -- annotation off 'Bar' and process the tail [Bar, z] recursively.
+    --
+    -- This leaves us with 'lhs = (Foo x) y' and 'rhs = Bar z'.
+    -- In case the tail contained more laziness annotations, they would be
+    -- processed similarly. This makes '~' right-associative.
+    go lhs [] = return lhs
+    go lhs (x:xs)
+      | L loc (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t) <- x
+      = do { rhs <- splitTilde (t:xs)
+           ; let r = mkLHsOpTy lhs (tildeOp loc) rhs
+           ; moveAnnotations loc (getLoc r)
+           ; return r }
+      | otherwise
+      = go (mkHsAppTy lhs x) xs
+
+    tildeOp loc = L (srcSpanFirstCharacter loc) eqTyCon_RDR
+
+-- | Either an operator or an operand.
+data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
+
+-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
+--   into a type.
+--
+-- User input: @F x y + G a b * X@
+-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]
+-- Output corresponds to what the user wrote assuming all operators are of the
+-- same fixity and right-associative.
+--
+-- It's a bit silly that we're doing it at all, as the renamer will have to
+-- rearrange this, and it'd be easier to keep things separate.
+mergeOps :: [Located TyEl] -> P (LHsType GhcPs)
+mergeOps = go [] id
+  where
+    -- clause (a):
+    -- when we encounter an operator, we must have accumulated
+    -- something for its rhs, and there must be something left
+    -- to build its lhs.
+    go acc ops_acc (L l (TyElOpr op):xs) =
+      if null acc || null xs
+        then failOpFewArgs (L l op)
+        else do { a <- splitTilde acc
+                ; go [] (\c -> mkLHsOpTy c (L l op) (ops_acc a)) xs }
+
+    -- clause (b):
+    -- whenever an operand is encountered, it is added to the accumulator
+    go acc ops_acc (L l (TyElOpd a):xs) = go (L l a:acc) ops_acc xs
+
+    -- clause (c):
+    -- at this point we know that 'acc' is non-empty because
+    -- there are three options when 'acc' can be empty:
+    -- 1. 'mergeOps' was called with an empty list, and this
+    --    should never happen
+    -- 2. 'mergeOps' was called with a list where the head is an
+    --    operator, this is handled by clause (a)
+    -- 3. 'mergeOps' was called with a list where the head is an
+    --    operand, this is handled by clause (b)
+    go acc ops_acc [] =
+      do { a <- splitTilde acc
+         ; return (ops_acc a) }
 
 ---------------------------------------------------------------------------
 -- Check for monad comprehensions
@@ -1187,34 +1378,35 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
 locMap f (L l a) = f l a >>= (\b -> return $ L l b)
 
 checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs)
-checkCmd _ (HsArrApp e1 e2 ptt haat b) =
-    return $ HsCmdArrApp e1 e2 ptt haat b
-checkCmd _ (HsArrForm e mf args) =
-    return $ HsCmdArrForm e Prefix mf args
-checkCmd _ (HsApp e1 e2) =
-    checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
-checkCmd _ (HsLam mg) =
-    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
-checkCmd _ (HsPar e) =
-    checkCommand e >>= (\c -> return $ HsCmdPar c)
-checkCmd _ (HsCase e mg) =
-    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
-checkCmd _ (HsIf cf ep et ee) = do
+checkCmd _ (HsArrApp _ e1 e2 haat b) =
+    return $ HsCmdArrApp noExt e1 e2 haat b
+checkCmd _ (HsArrForm _ e mf args) =
+    return $ HsCmdArrForm noExt e Prefix mf args
+checkCmd _ (HsApp _ e1 e2) =
+    checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2)
+checkCmd _ (HsLam _ mg) =
+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg')
+checkCmd _ (HsPar _ e) =
+    checkCommand e >>= (\c -> return $ HsCmdPar noExt c)
+checkCmd _ (HsCase _ e mg) =
+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg')
+checkCmd _ (HsIf _ cf ep et ee) = do
     pt <- checkCommand et
     pe <- checkCommand ee
-    return $ HsCmdIf cf ep pt pe
-checkCmd _ (HsLet lb e) =
-    checkCommand e >>= (\c -> return $ HsCmdLet lb c)
-checkCmd _ (HsDo DoExpr (L l stmts) ty) =
-    mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
-
-checkCmd _ (OpApp eLeft op _fixity eRight) = do
+    return $ HsCmdIf noExt cf ep pt pe
+checkCmd _ (HsLet _ lb e) =
+    checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c)
+checkCmd _ (HsDo _ DoExpr (L l stmts)) =
+    mapM checkCmdLStmt stmts >>=
+    (\ss -> return $ HsCmdDo noExt (L l ss) )
+
+checkCmd _ (OpApp _ eLeft op eRight) = do
     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
     c1 <- checkCommand eLeft
     c2 <- checkCommand eRight
-    let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
-        arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
-    return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
+    let arg1 = L (getLoc c1) $ HsCmdTop noExt c1
+        arg2 = L (getLoc c2) $ HsCmdTop noExt c2
+    return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2]
 
 checkCmd l e = cmdFail l e
 
@@ -1222,39 +1414,44 @@ checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs)
 checkCmdLStmt = locMap checkCmdStmt
 
 checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs)
-checkCmdStmt _ (LastStmt e s r) =
-    checkCommand e >>= (\c -> return $ LastStmt c s r)
-checkCmdStmt _ (BindStmt pat e b f t) =
-    checkCommand e >>= (\c -> return $ BindStmt pat c b f t)
-checkCmdStmt _ (BodyStmt e t g ty) =
-    checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
-checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
+checkCmdStmt _ (LastStmt x e s r) =
+    checkCommand e >>= (\c -> return $ LastStmt x c s r)
+checkCmdStmt _ (BindStmt x pat e b f) =
+    checkCommand e >>= (\c -> return $ BindStmt x pat c b f)
+checkCmdStmt _ (BodyStmt x e t g) =
+    checkCommand e >>= (\c -> return $ BodyStmt x c t g)
+checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds
 checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
     ss <- mapM checkCmdLStmt stmts
-    return $ stmt { recS_stmts = ss }
+    return $ stmt { recS_ext = noExt, recS_stmts = ss }
+checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt"
 checkCmdStmt l stmt = cmdStmtFail l stmt
 
 checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs)
                    -> P (MatchGroup GhcPs (LHsCmd GhcPs))
 checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
     ms' <- mapM (locMap $ const convert) ms
-    return $ mg { mg_alts = L l ms' }
-    where convert (Match mf pat mty grhss) = do
+    return $ mg { mg_ext = noExt, mg_alts = L l ms' }
+    where convert match@(Match { m_grhss = grhss }) = do
             grhss' <- checkCmdGRHSs grhss
-            return $ Match mf pat mty grhss'
+            return $ match { m_ext = noExt, m_grhss = grhss'}
+          convert (XMatch _) = panic "checkCmdMatchGroup.XMatch"
+checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup"
 
 checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs))
-checkCmdGRHSs (GRHSs grhss binds) = do
+checkCmdGRHSs (GRHSs x grhss binds) = do
     grhss' <- mapM checkCmdGRHS grhss
-    return $ GRHSs grhss' binds
+    return $ GRHSs x grhss' binds
+checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs"
 
 checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs))
 checkCmdGRHS = locMap $ const convert
   where
-    convert (GRHS stmts e) = do
+    convert (GRHS x stmts e) = do
         c <- checkCommand e
 --        cmdStmts <- mapM checkCmdLStmt stmts
-        return $ GRHS {- cmdStmts -} stmts c
+        return $ GRHS x {- cmdStmts -} stmts c
+    convert (XGRHS _) = panic "checkCmdGRHS"
 
 
 cmdFail :: SrcSpan -> HsExpr GhcPs -> P a
@@ -1278,7 +1475,7 @@ mkRecConstrOrUpdate
         -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)
         -> P (HsExpr GhcPs)
 
-mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)
   | isRdrDataCon c
   = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))
 mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
@@ -1287,23 +1484,23 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd)
 
 mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs
 mkRdrRecordUpd exp flds
-  = RecordUpd { rupd_expr = exp
-              , rupd_flds = flds
-              , rupd_cons    = PlaceHolder, rupd_in_tys  = PlaceHolder
-              , rupd_out_tys = PlaceHolder, rupd_wrap    = PlaceHolder }
+  = RecordUpd { rupd_ext  = noExt
+              , rupd_expr = exp
+              , rupd_flds = flds }
 
 mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs
 mkRdrRecordCon con flds
-  = RecordCon { rcon_con_name = con, rcon_flds = flds
-              , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+  = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds }
 
 mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg
 mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
 mk_rec_fields fs True  = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
 
 mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
-mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
-  = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
+mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
+  = HsRecField (L loc (Unambiguous noExt rdr)) arg pun
+mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _)
+  = panic "mk_rec_upd_field"
 
 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
                -> InlinePragma
@@ -1360,10 +1557,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
         funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
         importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
 
-    returnSpec spec = return $ ForD $ ForeignImport
-          { fd_name   = v
+    returnSpec spec = return $ ForD noExt $ ForeignImport
+          { fd_i_ext  = noExt
+          , fd_name   = v
           , fd_sig_ty = ty
-          , fd_co     = noForeignImportCoercionYet
           , fd_fi     = spec
           }
 
@@ -1433,9 +1630,8 @@ mkExport :: Located CCallConv
          -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)
          -> P (HsDecl GhcPs)
 mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
- = return $ ForD $
-   ForeignExport { fd_name = v, fd_sig_ty = ty
-                 , fd_co = noForeignExportCoercionYet
+ = return $ ForD noExt $
+   ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty
                  , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
                                    (L le esrc) }
   where
@@ -1468,11 +1664,11 @@ mkModuleImpExp (L l specname) subs =
   case subs of
     ImpExpAbs
       | isVarNameSpace (rdrNameSpace name)
-                               -> return $ IEVar (L l (ieNameFromSpec specname))
-      | otherwise              -> IEThingAbs . L l <$> nameT
-    ImpExpAll                  -> IEThingAll . L l <$> nameT
-    ImpExpList xs              ->
-      (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) [])
+                         -> return $ IEVar noExt (L l (ieNameFromSpec specname))
+      | otherwise        -> IEThingAbs noExt . L l <$> nameT
+    ImpExpAll            -> IEThingAll noExt . L l <$> nameT
+    ImpExpList xs        ->
+      (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) [])
         <$> nameT
     ImpExpAllWith xs                       ->
       do allowed <- extension patternSynonymsEnabled
@@ -1482,7 +1678,8 @@ mkModuleImpExp (L l specname) subs =
                 pos   = maybe NoIEWildcard IEWildcard
                           (findIndex isImpExpQcWildcard withs)
                 ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
-            in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT
+            in (\newName
+                        -> IEThingWith noExt (L l newName) pos ies []) <$> nameT
           else parseErrorSDoc l
             (text "Illegal export form (use PatternSynonyms to enable)")
   where
@@ -1519,7 +1716,7 @@ mkTypeImpExp name =
 
 checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
 checkImportSpec ie@(L _ specs) =
-    case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of
+    case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
       [] -> return ie
       (l:_) -> importSpecError l
   where
@@ -1543,11 +1740,49 @@ isImpExpQcWildcard ImpExpQcWildcard = True
 isImpExpQcWildcard _                = False
 
 -----------------------------------------------------------------------------
+-- Warnings and failures
+
+warnStarIsType :: SrcSpan -> P ()
+warnStarIsType span = addWarning Opt_WarnStarIsType span msg
+  where
+    msg =  text "Using" <+> quotes (text "*")
+           <+> text "(or its Unicode variant) to mean"
+           <+> quotes (text "Data.Kind.Type")
+        $$ text "relies on the StarIsType extension."
+        $$ text "Suggested fix: use" <+> quotes (text "Type")
+           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
+
+warnStarBndr :: SrcSpan -> P ()
+warnStarBndr span = addWarning Opt_WarnStarBinder span msg
+  where
+    msg =  text "Found binding occurrence of" <+> quotes (text "*")
+           <+> text "yet StarIsType is enabled."
+        $$ text "NB. To use (or export) this operator in"
+           <+> text "modules with StarIsType,"
+        $$ text "    including the definition module, you must qualify it."
+
+failOpFewArgs :: Located RdrName -> P a
+failOpFewArgs (L loc op) =
+  do { star_is_type <- extension starIsTypeEnabled
+     ; let msg = too_few $$ starInfo star_is_type op
+     ; parseErrorSDoc loc msg }
+  where
+    too_few = text "Operator applied to too few arguments:" <+> ppr op
+
+-----------------------------------------------------------------------------
 -- Misc utils
 
 parseErrorSDoc :: SrcSpan -> SDoc -> P a
 parseErrorSDoc span s = failSpanMsgP span s
 
+-- | Hint about bang patterns, assuming @BangPatterns@ is off.
+hintBangPat :: SrcSpan -> HsExpr GhcPs -> P ()
+hintBangPat span e = do
+    bang_on <- extension bangPatEnabled
+    unless bang_on $
+      parseErrorSDoc span
+        (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
+
 data SumOrTuple
   = Sum ConTag Arity (LHsExpr GhcPs)
   | Tuple [LHsTupArg GhcPs]
@@ -1555,11 +1790,11 @@ data SumOrTuple
 mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
 
 -- Tuple
-mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity)
+mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
 
 -- Sum
 mkSumOrTuple Unboxed _ (Sum alt arity e) =
-    return (ExplicitSum alt arity e PlaceHolder)
+    return (ExplicitSum noExt alt arity e)
 mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
     parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e))
   where
@@ -1568,3 +1803,8 @@ mkSumOrTuple Boxed l (Sum alt arity (L _ e)) =
       text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")"
 
     ppr_bars n = hsep (replicate n (Outputable.char '|'))
+
+mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
+mkLHsOpTy x op y =
+  let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
+  in L loc (mkHsOpTy x op y)
diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c
index fdaea44cc7..eca3e3d25c 100644
--- a/compiler/parser/cutils.c
+++ b/compiler/parser/cutils.c
@@ -13,23 +13,6 @@ places in the GHC library.
 #include <unistd.h>
 #endif
 
-/*
-Calling 'strlen' and 'memcpy' directly gives problems with GCC's inliner,
-and causes gcc to require too many registers on x84
-*/
-
-HsInt
-ghc_strlen( HsPtr a )
-{
-    return (strlen((char *)a));
-}
-
-HsInt
-ghc_memcmp( HsPtr a1, HsPtr a2, HsInt len )
-{
-    return (memcmp((char *)a1, a2, len));
-}
-
 void
 enableTimingStats( void )       /* called from the driver */
 {
diff --git a/compiler/parser/cutils.h b/compiler/parser/cutils.h
index 0c8ab12a2c..009fffa86f 100644
--- a/compiler/parser/cutils.h
+++ b/compiler/parser/cutils.h
@@ -6,10 +6,5 @@
 
 #include "HsFFI.h"
 
-// Out-of-line string functions, see compiler/utils/FastString.hs
-HsInt ghc_strlen( HsAddr a );
-HsInt ghc_memcmp( HsAddr a1, HsAddr a2, HsInt len );
-
-
 void enableTimingStats( void );
 void setHeapSize( HsInt size );
diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs
index ff893ede02..c143b1ed1e 100644
--- a/compiler/prelude/ForeignCall.hs
+++ b/compiler/prelude/ForeignCall.hs
@@ -18,6 +18,8 @@ module ForeignCall (
         Header(..), CType(..),
     ) where
 
+import GhcPrelude
+
 import FastString
 import Binary
 import Outputable
@@ -196,7 +198,7 @@ instance Outputable CExportSpec where
 
 instance Outputable CCallSpec where
   ppr (CCallSpec fun cconv safety)
-    = hcat [ ifPprDebug callconv, ppr_fun fun ]
+    = hcat [ whenPprDebug callconv, ppr_fun fun ]
     where
       callconv = text "{-" <> ppr cconv <> text "-}"
 
diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs
index 8f1b0b6347..00085cad0b 100644
--- a/compiler/prelude/KnownUniques.hs
+++ b/compiler/prelude/KnownUniques.hs
@@ -26,6 +26,8 @@ module KnownUniques
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TysWiredIn
 import TyCon
 import DataCon
@@ -79,7 +81,8 @@ knownUniqueName u =
 
 mkSumTyConUnique :: Arity -> Unique
 mkSumTyConUnique arity =
-    ASSERT(arity < 0xff)
+    ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the
+                         -- alternative
     mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)
 
 mkSumDataConUnique :: ConTagZ -> Arity -> Unique
@@ -98,16 +101,18 @@ getUnboxedSumName n
       _   -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag)
   | tag == 0x0
   = dataConName $ sumDataCon (alt + 1) arity
+  | tag == 0x1
+  = getName $ dataConWrapId $ sumDataCon (alt + 1) arity
   | tag == 0x2
   = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity
   | otherwise
   = pprPanic "getUnboxedSumName" (ppr n)
   where
     arity = n `shiftR` 8
-    alt = (n .&. 0xff) `shiftR` 2
+    alt = (n .&. 0xfc) `shiftR` 2
     tag = 0x3 .&. n
     getRep tycon =
-        fromMaybe (pprPanic "getUnboxedSumName" (ppr tycon))
+        fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon))
         $ tyConRepName_maybe tycon
 
 -- Note [Uniques for tuple type and data constructors]
diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot
index eeb478526d..b217c84aca 100644
--- a/compiler/prelude/KnownUniques.hs-boot
+++ b/compiler/prelude/KnownUniques.hs-boot
@@ -1,5 +1,6 @@
 module KnownUniques where
 
+import GhcPrelude
 import Unique
 import Name
 import BasicTypes
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index 47f41fbf73..a76a78adc9 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -46,6 +46,8 @@ module PrelInfo (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import KnownUniques
 import Unique           ( isValidKnownKeyUnique )
 
@@ -169,8 +171,8 @@ knownKeyNamesOkay all_names
   | otherwise
   = Just badNamesStr
   where
-    namesEnv      = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
-                          emptyUFM all_names
+    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)
+                           emptyUFM all_names
     badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
     badNamesPairs = nonDetUFMToList badNamesEnv
       -- It's OK to use nonDetUFMToList here because the ordering only affects
@@ -250,7 +252,7 @@ ghcPrimExports
  = map (avail . idName) ghcPrimIds ++
    map (avail . idName . primOpId) allThePrimOps ++
    [ AvailTC n [n] []
-   | tc <- funTyCon : primTyCons, let n = tyConName tc  ]
+   | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]
 
 {-
 ************************************************************************
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 1f9f8f33df..d75ad47c6d 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -24,7 +24,7 @@ Nota Bene: all Names defined in here should come from the base package
    One of these Names contains
         (a) the module and occurrence name of the thing
         (b) its Unique
-   The may way the compiler "knows about" one of these things is
+   The way the compiler "knows about" one of these things is
    where the type checker or desugarer needs to look it up. For
    example, when desugaring list comprehensions the desugarer
    needs to conjure up 'foldr'.  It does this by looking up
@@ -83,7 +83,6 @@ This is accomplished through a combination of mechanisms:
 
 Note [Infinite families of known-key names]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Infinite families of known-key things (e.g. tuples and sums) pose a tricky
 problem: we can't add them to the knownKeyNames finite map which we use to
 ensure that, e.g., a reference to (,) gets assigned the right unique (if this
@@ -128,6 +127,8 @@ module PrelNames (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Module
 import OccName
 import RdrName
@@ -183,7 +184,7 @@ names with uniques.  These ones are the *non* wired-in ones.  The
 wired in ones are defined in TysWiredIn etc.
 -}
 
-basicKnownKeyNames :: [Name]
+basicKnownKeyNames :: [Name]  -- See Note [Known-key names]
 basicKnownKeyNames
  = genericTyConNames
  ++ [   --  Classes.  *Must* include:
@@ -215,6 +216,7 @@ basicKnownKeyNames
         -- See Note [TyConRepNames for non-wired-in TyCons]
         ioTyConName, ioDataConName,
         runMainIOName,
+        runRWName,
 
         -- Type representation types
         trModuleTyConName, trModuleDataConName,
@@ -238,6 +240,7 @@ basicKnownKeyNames
         typeLitSymbolDataConName,
         typeLitNatDataConName,
         typeRepIdName,
+        mkTrTypeName,
         mkTrConName,
         mkTrAppName,
         mkTrFunName,
@@ -330,8 +333,9 @@ basicKnownKeyNames
         otherwiseIdName, inlineIdName,
         eqStringName, assertName, breakpointName, breakpointCondName,
         breakpointAutoName,  opaqueTyConName,
-        assertErrorName,
+        assertErrorName, traceName,
         printName, fstName, sndName,
+        dollarName,
 
         -- Integer
         integerTyConName, mkIntegerName,
@@ -354,7 +358,9 @@ basicKnownKeyNames
 
         -- Natural
         naturalTyConName,
-        naturalFromIntegerName,
+        naturalFromIntegerName, naturalToIntegerName,
+        plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName,
+        wordToNaturalName,
 
         -- Float/Double
         rationalToFloatName,
@@ -387,7 +393,7 @@ basicKnownKeyNames
 
         -- The Ordering type
         , orderingTyConName
-        , ltDataConName, eqDataConName, gtDataConName
+        , ordLTDataConName, ordEQDataConName, ordGTDataConName
 
         -- The SPEC type for SpecConstr
         , specTyConName
@@ -427,11 +433,8 @@ basicKnownKeyNames
         , typeErrorVAppendDataConName
         , typeErrorShowTypeDataConName
 
-        -- homogeneous equality
-        , eqTyConName
-
     ] ++ case cIntegerLibraryType of
-           IntegerGMP    -> [integerSDataConName]
+           IntegerGMP    -> [integerSDataConName,naturalSDataConName]
            IntegerSimple -> []
 
 genericTyConNames :: [Name]
@@ -469,9 +472,9 @@ pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
 gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,
-    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
-    dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP,
+    gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
+    gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+    dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
     gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
@@ -479,7 +482,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
     aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,
-    dATA_COERCE :: Module
+    dATA_COERCE, dEBUG_TRACE :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
@@ -493,6 +496,7 @@ gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")
 gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")
 gHC_READ        = mkBaseModule (fsLit "GHC.Read")
 gHC_NUM         = mkBaseModule (fsLit "GHC.Num")
+gHC_MAYBE       = mkBaseModule (fsLit "GHC.Maybe")
 gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
 gHC_NATURAL     = mkBaseModule (fsLit "GHC.Natural")
 gHC_LIST        = mkBaseModule (fsLit "GHC.List")
@@ -502,8 +506,6 @@ dATA_EITHER     = mkBaseModule (fsLit "Data.Either")
 dATA_STRING     = mkBaseModule (fsLit "Data.String")
 dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")
 dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
-dATA_SEMIGROUP  = mkBaseModule (fsLit "Data.Semigroup")
-dATA_MONOID     = mkBaseModule (fsLit "Data.Monoid")
 gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")
 gHC_IO          = mkBaseModule (fsLit "GHC.IO")
 gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
@@ -539,9 +541,7 @@ gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")
 gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")
 dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality")
 dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")
-
-gHC_PARR' :: Module
-gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
+dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")
 
 gHC_SRCLOC :: Module
 gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -630,9 +630,9 @@ le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")
 lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")
 gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")
 compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")
-ltTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "LT")
-eqTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "EQ")
-gtTag_RDR               = dataQual_RDR gHC_TYPES (fsLit "GT")
+ltTag_RDR               = nameRdrName  ordLTDataConName
+eqTag_RDR               = nameRdrName  ordEQDataConName
+gtTag_RDR               = nameRdrName  ordGTDataConName
 
 eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR
     :: RdrName
@@ -643,10 +643,11 @@ enumClass_RDR           = nameRdrName enumClassName
 monadClass_RDR          = nameRdrName monadClassName
 
 map_RDR, append_RDR :: RdrName
-map_RDR                 = varQual_RDR gHC_BASE (fsLit "map")
-append_RDR              = varQual_RDR gHC_BASE (fsLit "++")
+map_RDR                 = nameRdrName mapName
+append_RDR              = nameRdrName appendName
 
-foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName
+foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP,
+  failM_RDR :: RdrName
 foldr_RDR               = nameRdrName foldrName
 build_RDR               = nameRdrName buildName
 returnM_RDR             = nameRdrName returnMName
@@ -742,6 +743,11 @@ choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")
 lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")
 expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")
 
+readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName
+readField_RDR           = varQual_RDR gHC_READ (fsLit "readField")
+readFieldHash_RDR       = varQual_RDR gHC_READ (fsLit "readFieldHash")
+readSymField_RDR        = varQual_RDR gHC_READ (fsLit "readSymField")
+
 punc_RDR, ident_RDR, symbol_RDR :: RdrName
 punc_RDR                = dataQual_RDR lEX (fsLit "Punc")
 ident_RDR               = dataQual_RDR lEX (fsLit "Ident")
@@ -817,9 +823,9 @@ conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
 
 prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
 infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")
-leftAssocDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
-rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
-notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName
+rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName
+notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName
 
 uAddrDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UAddr")
 uCharDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UChar")
@@ -838,7 +844,7 @@ uWordHash_RDR   = varQual_RDR gHC_GENERICS (fsLit "uWord#")
 fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,
     foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,
     mappend_RDR :: RdrName
-fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")
+fmap_RDR                = nameRdrName fmapName
 replace_RDR             = varQual_RDR gHC_BASE (fsLit "<$")
 pure_RDR                = nameRdrName pureAName
 ap_RDR                  = nameRdrName apAName
@@ -848,11 +854,8 @@ foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
 null_RDR                = varQual_RDR dATA_FOLDABLE       (fsLit "null")
 all_RDR                 = varQual_RDR dATA_FOLDABLE       (fsLit "all")
 traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
-mempty_RDR              = varQual_RDR gHC_BASE            (fsLit "mempty")
-mappend_RDR             = varQual_RDR gHC_BASE            (fsLit "mappend")
-
-eqTyCon_RDR :: RdrName
-eqTyCon_RDR = tcQual_RDR dATA_TYPE_EQUALITY (fsLit "~")
+mempty_RDR              = nameRdrName memptyName
+mappend_RDR             = nameRdrName mappendName
 
 ----------------------
 varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR
@@ -872,22 +875,20 @@ dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)
 Many of these Names are not really "built in", but some parts of the
 compiler (notably the deriving mechanism) need to mention their names,
 and it's convenient to write them all down in one place.
-
---MetaHaskell Extension  add the constrs and the lower case case
--- guys as well (perhaps) e.g. see  trueDataConName     below
 -}
 
 wildCardName :: Name
 wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
 
-runMainIOName :: Name
+runMainIOName, runRWName :: Name
 runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey
+runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey
 
-orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name
+orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name
 orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey
-ltDataConName     = dcQual gHC_TYPES (fsLit "LT") ltDataConKey
-eqDataConName     = dcQual gHC_TYPES (fsLit "EQ") eqDataConKey
-gtDataConName     = dcQual gHC_TYPES (fsLit "GT") gtDataConKey
+ordLTDataConName     = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey
+ordEQDataConName     = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey
+ordGTDataConName     = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey
 
 specTyConName :: Name
 specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey
@@ -1020,8 +1021,8 @@ traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") trave
 
 -- Classes (Semigroup, Monoid)
 semigroupClassName, sappendName :: Name
-semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey
-sappendName        = varQual dATA_SEMIGROUP (fsLit "<>")        sappendClassOpKey
+semigroupClassName = clsQual gHC_BASE       (fsLit "Semigroup") semigroupClassKey
+sappendName        = varQual gHC_BASE       (fsLit "<>")        sappendClassOpKey
 monoidClassName, memptyName, mappendName, mconcatName :: Name
 monoidClassName    = clsQual gHC_BASE       (fsLit "Monoid")    monoidClassKey
 memptyName         = varQual gHC_BASE       (fsLit "mempty")    memptyClassOpKey
@@ -1054,8 +1055,8 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
 fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
     mapName, appendName, assertName,
     breakpointName, breakpointCondName, breakpointAutoName,
-    opaqueTyConName :: Name
-fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
+    opaqueTyConName, dollarName :: Name
+dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey
 otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey
 foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey
 buildName         = varQual gHC_BASE (fsLit "build")      buildIdKey
@@ -1067,6 +1068,7 @@ breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
 breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
 breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey
 opaqueTyConName   = tcQual  gHC_BASE (fsLit "Opaque")     opaqueTyConKey
+fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
 
 breakpointJumpName :: Name
 breakpointJumpName
@@ -1117,7 +1119,7 @@ integerTyConName, mkIntegerName, integerSDataConName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
 integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey
-integerSDataConName   = dcQual gHC_INTEGER_TYPE (fsLit n)                   integerSDataConKey
+integerSDataConName   = dcQual gHC_INTEGER_TYPE (fsLit n)                    integerSDataConKey
   where n = case cIntegerLibraryType of
             IntegerGMP    -> "S#"
             IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
@@ -1165,12 +1167,25 @@ shiftRIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger")     shi
 bitIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "bitInteger")        bitIntegerIdKey
 
 -- GHC.Natural types
-naturalTyConName :: Name
+naturalTyConName, naturalSDataConName :: Name
 naturalTyConName     = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey
+naturalSDataConName  = dcQual gHC_NATURAL (fsLit n)         naturalSDataConKey
+  where n = case cIntegerLibraryType of
+            IntegerGMP    -> "NatS#"
+            IntegerSimple -> panic "naturalSDataConName evaluated for integer-simple"
 
 naturalFromIntegerName :: Name
 naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey
 
+naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName,
+   mkNaturalName, wordToNaturalName :: Name
+naturalToIntegerName  = varQual gHC_NATURAL (fsLit "naturalToInteger")  naturalToIntegerIdKey
+plusNaturalName       = varQual gHC_NATURAL (fsLit "plusNatural")       plusNaturalIdKey
+minusNaturalName      = varQual gHC_NATURAL (fsLit "minusNatural")      minusNaturalIdKey
+timesNaturalName      = varQual gHC_NATURAL (fsLit "timesNatural")      timesNaturalIdKey
+mkNaturalName         = varQual gHC_NATURAL (fsLit "mkNatural")         mkNaturalIdKey
+wordToNaturalName     = varQual gHC_NATURAL (fsLit "wordToNatural#")    wordToNaturalIdKey
+
 -- GHC.Real types and classes
 rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
     integralClassName, realFracClassName, fractionalClassName,
@@ -1251,6 +1266,7 @@ typeableClassName
   , typeRepTyConName
   , someTypeRepTyConName
   , someTypeRepDataConName
+  , mkTrTypeName
   , mkTrConName
   , mkTrAppName
   , mkTrFunName
@@ -1264,6 +1280,7 @@ typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeR
 someTypeRepTyConName   = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey
 someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey
 typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey
+mkTrTypeName          = varQual tYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey
 mkTrConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey
 mkTrAppName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey
 mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey
@@ -1316,6 +1333,10 @@ dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey
 assertErrorName    :: Name
 assertErrorName   = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey
 
+-- Debug.Trace
+traceName          :: Name
+traceName         = varQual dEBUG_TRACE (fsLit "trace") traceKey
+
 -- Enum module (Enum, Bounded)
 enumClassName, enumFromName, enumFromToName, enumFromThenName,
     enumFromThenToName, boundedClassName :: Name
@@ -1505,10 +1526,6 @@ fingerprintDataConName :: Name
 fingerprintDataConName =
     dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
 
--- homogeneous equality. See Note [The equality types story] in TysPrim
-eqTyConName :: Name
-eqTyConName        = tcQual dATA_TYPE_EQUALITY (fsLit "~")         eqTyConKey
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1731,10 +1748,6 @@ funPtrTyConKey                          = mkPreludeTyConUnique 76
 tVarPrimTyConKey                        = mkPreludeTyConUnique 77
 compactPrimTyConKey                     = mkPreludeTyConUnique 78
 
--- Parallel array type constructor
-parrTyConKey :: Unique
-parrTyConKey                            = mkPreludeTyConUnique 82
-
 -- dotnet interop
 objectTyConKey :: Unique
 objectTyConKey                          = mkPreludeTyConUnique 83
@@ -1744,14 +1757,11 @@ eitherTyConKey                          = mkPreludeTyConUnique 84
 
 -- Kind constructors
 liftedTypeKindTyConKey, tYPETyConKey,
-  constraintKindTyConKey,
-  starKindTyConKey, unicodeStarKindTyConKey, runtimeRepTyConKey,
+  constraintKindTyConKey, runtimeRepTyConKey,
   vecCountTyConKey, vecElemTyConKey :: Unique
 liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87
 tYPETyConKey                            = mkPreludeTyConUnique 88
 constraintKindTyConKey                  = mkPreludeTyConUnique 92
-starKindTyConKey                        = mkPreludeTyConUnique 93
-unicodeStarKindTyConKey                 = mkPreludeTyConUnique 94
 runtimeRepTyConKey                      = mkPreludeTyConUnique 95
 vecCountTyConKey                        = mkPreludeTyConUnique 96
 vecElemTyConKey                         = mkPreludeTyConUnique 97
@@ -1816,6 +1826,9 @@ typeNatKindConNameKey, typeSymbolKindConNameKey,
   typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
   typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
   , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
+  , typeNatDivTyFamNameKey
+  , typeNatModTyFamNameKey
+  , typeNatLogTyFamNameKey
   :: Unique
 typeNatKindConNameKey     = mkPreludeTyConUnique 164
 typeSymbolKindConNameKey  = mkPreludeTyConUnique 165
@@ -1826,48 +1839,51 @@ typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 169
 typeNatSubTyFamNameKey    = mkPreludeTyConUnique 170
 typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
 typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 172
+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 173
+typeNatModTyFamNameKey  = mkPreludeTyConUnique 174
+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 175
 
 -- Custom user type-errors
 errorMessageTypeErrorFamKey :: Unique
-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 173
+errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 176
 
 
 
 ntTyConKey:: Unique
-ntTyConKey = mkPreludeTyConUnique 174
+ntTyConKey = mkPreludeTyConUnique 177
 coercibleTyConKey :: Unique
-coercibleTyConKey = mkPreludeTyConUnique 175
+coercibleTyConKey = mkPreludeTyConUnique 178
 
 proxyPrimTyConKey :: Unique
-proxyPrimTyConKey = mkPreludeTyConUnique 176
+proxyPrimTyConKey = mkPreludeTyConUnique 179
 
 specTyConKey :: Unique
-specTyConKey = mkPreludeTyConUnique 177
+specTyConKey = mkPreludeTyConUnique 180
 
 anyTyConKey :: Unique
-anyTyConKey = mkPreludeTyConUnique 178
+anyTyConKey = mkPreludeTyConUnique 181
 
-smallArrayPrimTyConKey        = mkPreludeTyConUnique  179
-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  180
+smallArrayPrimTyConKey        = mkPreludeTyConUnique  182
+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  183
 
 staticPtrTyConKey  :: Unique
-staticPtrTyConKey  = mkPreludeTyConUnique 181
+staticPtrTyConKey  = mkPreludeTyConUnique 184
 
 staticPtrInfoTyConKey :: Unique
-staticPtrInfoTyConKey = mkPreludeTyConUnique 182
+staticPtrInfoTyConKey = mkPreludeTyConUnique 185
 
 callStackTyConKey :: Unique
-callStackTyConKey = mkPreludeTyConUnique 183
+callStackTyConKey = mkPreludeTyConUnique 186
 
 -- Typeables
 typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique
-typeRepTyConKey       = mkPreludeTyConUnique 184
-someTypeRepTyConKey   = mkPreludeTyConUnique 185
-someTypeRepDataConKey = mkPreludeTyConUnique 186
+typeRepTyConKey       = mkPreludeTyConUnique 187
+someTypeRepTyConKey   = mkPreludeTyConUnique 188
+someTypeRepDataConKey = mkPreludeTyConUnique 189
 
 
 typeSymbolAppendFamNameKey :: Unique
-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 187
+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190
 
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES TyConUniques 200-299
@@ -1891,7 +1907,7 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
     floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
     ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
     word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey,
-    coercibleDataConKey, nothingDataConKey, justDataConKey :: Unique
+    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique
 
 charDataConKey                          = mkPreludeDataConUnique  1
 consDataConKey                          = mkPreludeDataConUnique  2
@@ -1902,6 +1918,7 @@ intDataConKey                           = mkPreludeDataConUnique  6
 integerSDataConKey                      = mkPreludeDataConUnique  7
 nothingDataConKey                       = mkPreludeDataConUnique  8
 justDataConKey                          = mkPreludeDataConUnique  9
+eqDataConKey                            = mkPreludeDataConUnique 10
 nilDataConKey                           = mkPreludeDataConUnique 11
 ratioDataConKey                         = mkPreludeDataConUnique 12
 word8DataConKey                         = mkPreludeDataConUnique 13
@@ -1919,18 +1936,15 @@ inlDataConKey                           = mkPreludeDataConUnique 21
 inrDataConKey                           = mkPreludeDataConUnique 22
 genUnitDataConKey                       = mkPreludeDataConUnique 23
 
--- Data constructor for parallel arrays
-parrDataConKey :: Unique
-parrDataConKey                          = mkPreludeDataConUnique 24
-
 leftDataConKey, rightDataConKey :: Unique
 leftDataConKey                          = mkPreludeDataConUnique 25
 rightDataConKey                         = mkPreludeDataConUnique 26
 
-ltDataConKey, eqDataConKey, gtDataConKey :: Unique
-ltDataConKey                            = mkPreludeDataConUnique 27
-eqDataConKey                            = mkPreludeDataConUnique 28
-gtDataConKey                            = mkPreludeDataConUnique 29
+ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique
+ordLTDataConKey                         = mkPreludeDataConUnique 27
+ordEQDataConKey                         = mkPreludeDataConUnique 28
+ordGTDataConKey                         = mkPreludeDataConUnique 29
+
 
 coercibleDataConKey                     = mkPreludeDataConUnique 32
 
@@ -2003,12 +2017,16 @@ tupleRepDataConKey                      = mkPreludeDataConUnique 72
 sumRepDataConKey                        = mkPreludeDataConUnique 73
 
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
-runtimeRepSimpleDataConKeys :: [Unique]
+runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
 liftedRepDataConKey :: Unique
-runtimeRepSimpleDataConKeys@(
-  liftedRepDataConKey : _)
+runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
   = map mkPreludeDataConUnique [74..82]
 
+unliftedRepDataConKeys = vecRepDataConKey :
+                         tupleRepDataConKey :
+                         sumRepDataConKey :
+                         unliftedSimpleRepDataConKeys
+
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 -- VecCount
 vecCountDataConKeys :: [Unique]
@@ -2052,13 +2070,14 @@ typeLitNatDataConKey      = mkPreludeDataConUnique 108
 
 wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
     buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
-    seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,
+    seqIdKey, eqStringIdKey,
     noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
     runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
     realWorldPrimIdKey, recConErrorIdKey,
     unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
     unpackCStringFoldrIdKey, unpackCStringIdKey,
-    typeErrorIdKey, divIntIdKey, modIntIdKey :: Unique
+    typeErrorIdKey, divIntIdKey, modIntIdKey,
+    absentSumFieldErrorIdKey :: Unique
 
 wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
 absentErrorIdKey              = mkPreludeMiscIdUnique  1
@@ -2069,7 +2088,6 @@ errorIdKey                    = mkPreludeMiscIdUnique  5
 foldrIdKey                    = mkPreludeMiscIdUnique  6
 recSelErrorIdKey              = mkPreludeMiscIdUnique  7
 seqIdKey                      = mkPreludeMiscIdUnique  8
-irrefutPatErrorIdKey          = mkPreludeMiscIdUnique  9
 eqStringIdKey                 = mkPreludeMiscIdUnique 10
 noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11
 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
@@ -2085,6 +2103,7 @@ voidPrimIdKey                 = mkPreludeMiscIdUnique 21
 typeErrorIdKey                = mkPreludeMiscIdUnique 22
 divIntIdKey                   = mkPreludeMiscIdUnique 23
 modIntIdKey                   = mkPreludeMiscIdUnique 24
+absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique 9
 
 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
     returnIOIdKey, newStablePtrIdKey,
@@ -2175,6 +2194,9 @@ assertErrorIdKey              = mkPreludeMiscIdUnique 105
 oneShotKey                    = mkPreludeMiscIdUnique 106
 runRWKey                      = mkPreludeMiscIdUnique 107
 
+traceKey :: Unique
+traceKey                      = mkPreludeMiscIdUnique 108
+
 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
     breakpointJumpIdKey, breakpointCondJumpIdKey,
     breakpointAutoJumpIdKey :: Unique
@@ -2311,6 +2333,7 @@ proxyHashKey = mkPreludeMiscIdUnique 502
 
 -- Used to make `Typeable` dictionaries
 mkTyConKey
+  , mkTrTypeKey
   , mkTrConKey
   , mkTrAppKey
   , mkTrFunKey
@@ -2319,12 +2342,13 @@ mkTyConKey
   , typeRepIdKey
   :: Unique
 mkTyConKey            = mkPreludeMiscIdUnique 503
-mkTrConKey            = mkPreludeMiscIdUnique 504
-mkTrAppKey            = mkPreludeMiscIdUnique 505
-typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
-typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
-typeRepIdKey          = mkPreludeMiscIdUnique 508
-mkTrFunKey            = mkPreludeMiscIdUnique 509
+mkTrTypeKey           = mkPreludeMiscIdUnique 504
+mkTrConKey            = mkPreludeMiscIdUnique 505
+mkTrAppKey            = mkPreludeMiscIdUnique 506
+typeNatTypeRepKey     = mkPreludeMiscIdUnique 507
+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508
+typeRepIdKey          = mkPreludeMiscIdUnique 509
+mkTrFunKey            = mkPreludeMiscIdUnique 510
 
 -- Representations for primitive types
 trTYPEKey
@@ -2332,10 +2356,10 @@ trTYPEKey
   , trRuntimeRepKey
   , tr'PtrRepLiftedKey
   :: Unique
-trTYPEKey              = mkPreludeMiscIdUnique 510
-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511
-trRuntimeRepKey        = mkPreludeMiscIdUnique 512
-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 513
+trTYPEKey              = mkPreludeMiscIdUnique 511
+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512
+trRuntimeRepKey        = mkPreludeMiscIdUnique 513
+tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 514
 
 -- KindReps for common cases
 starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
@@ -2345,12 +2369,14 @@ starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522
 
 -- Dynamic
 toDynIdKey :: Unique
-toDynIdKey            = mkPreludeMiscIdUnique 550
+toDynIdKey            = mkPreludeMiscIdUnique 523
+
 
 bitIntegerIdKey :: Unique
-bitIntegerIdKey       = mkPreludeMiscIdUnique 551
+bitIntegerIdKey       = mkPreludeMiscIdUnique 550
 
-heqSCSelIdKey, coercibleSCSelIdKey :: Unique
+heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique
+eqSCSelIdKey        = mkPreludeMiscIdUnique 551
 heqSCSelIdKey       = mkPreludeMiscIdUnique 552
 coercibleSCSelIdKey = mkPreludeMiscIdUnique 553
 
@@ -2373,8 +2399,17 @@ makeStaticKey :: Unique
 makeStaticKey = mkPreludeMiscIdUnique 561
 
 -- Natural
-naturalFromIntegerIdKey :: Unique
+naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
+   minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
+   naturalSDataConKey, wordToNaturalIdKey :: Unique
 naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
+naturalToIntegerIdKey   = mkPreludeMiscIdUnique 563
+plusNaturalIdKey        = mkPreludeMiscIdUnique 564
+minusNaturalIdKey       = mkPreludeMiscIdUnique 565
+timesNaturalIdKey       = mkPreludeMiscIdUnique 566
+mkNaturalIdKey          = mkPreludeMiscIdUnique 567
+naturalSDataConKey      = mkPreludeMiscIdUnique 568
+wordToNaturalIdKey      = mkPreludeMiscIdUnique 569
 
 {-
 ************************************************************************
@@ -2453,5 +2488,5 @@ The following names should be considered by GHCi to be in scope always.
 pretendNameIsInScope :: Name -> Bool
 pretendNameIsInScope n
   = any (n `hasKey`)
-    [ starKindTyConKey, liftedTypeKindTyConKey, tYPETyConKey
+    [ liftedTypeKindTyConKey, tYPETyConKey
     , runtimeRepTyConKey, liftedRepDataConKey ]
diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot
index e25c83618f..0bd74d5577 100644
--- a/compiler/prelude/PrelNames.hs-boot
+++ b/compiler/prelude/PrelNames.hs-boot
@@ -4,5 +4,4 @@ import Module
 import Unique
 
 mAIN :: Module
-starKindTyConKey :: Unique
-unicodeStarKindTyConKey :: Unique
+liftedTypeKindTyConKey :: Unique
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 1ef0565ff3..80cfa20ba3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -12,7 +12,7 @@ ToDo:
    (i1 + i2) only if it results in a valid Float.
 -}
 
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 
 module PrelRules
@@ -25,6 +25,8 @@ where
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
 
 import CoreSyn
@@ -35,10 +37,11 @@ import CoreOpt     ( exprIsLiteral_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
-import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
-                   , unwrapNewTyCon_maybe, tyConDataCons )
-import DataCon     ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
-import CoreUtils   ( cheapEqExpr, exprIsHNF )
+import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
+                   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
+                   , tyConFamilySize )
+import DataCon     ( dataConTagZ, dataConTyCon, dataConWorkId )
+import CoreUtils   ( cheapEqExpr, exprIsHNF, exprType )
 import CoreUnfold  ( exprIsConApp_maybe )
 import Type
 import OccName     ( occNameFS )
@@ -56,9 +59,7 @@ import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 import Control.Applicative ( Alternative(..) )
 
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import Data.Bits as Bits
 import qualified Data.ByteString as BS
 import Data.Int
@@ -90,13 +91,24 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
 
 -- Int operations
 primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
-                                               , identityDynFlags zeroi ]
+                                               , identityDynFlags zeroi
+                                               , numFoldingRules IntAddOp intPrimOps
+                                               ]
 primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
                                                , rightIdentityDynFlags zeroi
-                                               , equalArgs >> retLit zeroi ]
+                                               , equalArgs >> retLit zeroi
+                                               , numFoldingRules IntSubOp intPrimOps
+                                               ]
+primOpRules nm IntAddCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
+                                               , identityCDynFlags zeroi ]
+primOpRules nm IntSubCOp   = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
+                                               , rightIdentityCDynFlags zeroi
+                                               , equalArgs >> retLitNoC zeroi ]
 primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
                                                , zeroElem zeroi
-                                               , identityDynFlags onei ]
+                                               , identityDynFlags onei
+                                               , numFoldingRules IntMulOp intPrimOps
+                                               ]
 primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
                                                , leftZero zeroi
                                                , rightIdentityDynFlags onei
@@ -122,21 +134,32 @@ primOpRules nm NotIOp      = mkPrimOpRule nm 1 [ unaryLit complementOp
                                                , inversePrimOp NotIOp ]
 primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp
                                                , inversePrimOp IntNegOp ]
-primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
+primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
                                                , rightIdentityDynFlags zeroi ]
-primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
+primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
                                                , rightIdentityDynFlags zeroi ]
-primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
+primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
                                                , rightIdentityDynFlags zeroi ]
 
 -- Word operations
 primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
-                                               , identityDynFlags zerow ]
+                                               , identityDynFlags zerow
+                                               , numFoldingRules WordAddOp wordPrimOps
+                                               ]
 primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
                                                , rightIdentityDynFlags zerow
-                                               , equalArgs >> retLit zerow ]
+                                               , equalArgs >> retLit zerow
+                                               , numFoldingRules WordSubOp wordPrimOps
+                                               ]
+primOpRules nm WordAddCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
+                                               , identityCDynFlags zerow ]
+primOpRules nm WordSubCOp  = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
+                                               , rightIdentityCDynFlags zerow
+                                               , equalArgs >> retLitNoC zerow ]
 primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
-                                               , identityDynFlags onew ]
+                                               , identityDynFlags onew
+                                               , numFoldingRules WordMulOp wordPrimOps
+                                               ]
 primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
                                                , rightIdentityDynFlags onew ]
 primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
@@ -157,8 +180,8 @@ primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
                                                , equalArgs >> retLit zerow ]
 primOpRules nm NotOp       = mkPrimOpRule nm 1 [ unaryLit complementOp
                                                , inversePrimOp NotOp ]
-primOpRules nm SllOp       = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
-primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
+primOpRules nm SllOp       = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
+primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
 
 -- coercions
 primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
@@ -361,12 +384,11 @@ cmpOp dflags cmp = go
 
     -- These compares are at different types
     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
-    go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
-    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
-    go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
-    go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
     go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
     go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
+    go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
+      | nt1 /= nt2 = Nothing
+      | otherwise  = done (i1 `cmp` i2)
     go _               _               = Nothing
 
 --------------------------
@@ -376,12 +398,13 @@ negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
 negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))
 negOp _      (MachDouble 0.0) = Nothing
 negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))
-negOp dflags (MachInt i)      = intResult dflags (-i)
+negOp dflags (LitNumber nt i t)
+   | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
 negOp _      _                = Nothing
 
 complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
-complementOp dflags (MachWord i) = wordResult dflags (complement i)
-complementOp dflags (MachInt i)  = intResult  dflags (complement i)
+complementOp dflags (LitNumber nt i t) =
+   Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
 complementOp _      _            = Nothing
 
 --------------------------
@@ -393,11 +416,18 @@ intOp2 = intOp2' . const
 intOp2' :: (Integral a, Integral b)
         => (DynFlags -> a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOp2' op dflags (MachInt i1) (MachInt i2) =
+intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
   let o = op dflags
   in  intResult dflags (fromInteger i1 `o` fromInteger i2)
 intOp2' _  _      _            _            = Nothing  -- Could find LitLit
 
+intOpC2 :: (Integral a, Integral b)
+        => (a -> b -> Integer)
+        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
+intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
+  intCResult dflags (fromInteger i1 `op` fromInteger i2)
+intOpC2 _  _      _            _            = Nothing  -- Could find LitLit
+
 shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
 -- Do this by converting to Word and back.  Obviously this won't work for big
@@ -412,29 +442,45 @@ retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
 retLit l = do dflags <- getDynFlags
               return $ Lit $ l dflags
 
+retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
+retLitNoC l = do dflags <- getDynFlags
+                 let lit = l dflags
+                 let ty = literalType lit
+                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]
+
 wordOp2 :: (Integral a, Integral b)
         => (a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOp2 op dflags (MachWord w1) (MachWord w2)
+wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
     = wordResult dflags (fromInteger w1 `op` fromInteger w2)
 wordOp2 _ _ _ _ = Nothing  -- Could find LitLit
 
-wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
+wordOpC2 :: (Integral a, Integral b)
+        => (a -> b -> Integer)
+        -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
+wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
+  wordCResult dflags (fromInteger w1 `op` fromInteger w2)
+wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit
+
+shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
                  -- Shifts take an Int; hence third arg of op is Int
 -- See Note [Guarding against silly shifts]
-wordShiftRule shift_op
+shiftRule shift_op
   = do { dflags <- getDynFlags
-       ; [e1, Lit (MachInt shift_len)] <- getArgs
+       ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
        ; case e1 of
            _ | shift_len == 0
              -> return e1
              | shift_len < 0 || wordSizeInBits dflags < shift_len
              -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
                                         ("Bad shift length" ++ show shift_len))
-           Lit (MachWord x)
+
+           -- Do the shift at type Integer, but shift length is Int
+           Lit (LitNumber nt x t)
              -> let op = shift_op dflags
-                in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
-                    -- Do the shift at type Integer, but shift length is Int
+                    y  = x `op` fromInteger shift_len
+                in  liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
+
            _ -> mzero }
 
 wordSizeInBits :: DynFlags -> Integer
@@ -524,30 +570,62 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dfla
 mkRuleFn _ _ _ _                                       = Nothing
 
 isMinBound :: DynFlags -> Literal -> Bool
-isMinBound _      (MachChar c)   = c == minBound
-isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags
-isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)
-isMinBound _      (MachWord i)   = i == 0
-isMinBound _      (MachWord64 i) = i == 0
-isMinBound _      _              = False
+isMinBound _      (MachChar c)       = c == minBound
+isMinBound dflags (LitNumber nt i _) = case nt of
+   LitNumInt     -> i == tARGET_MIN_INT dflags
+   LitNumInt64   -> i == toInteger (minBound :: Int64)
+   LitNumWord    -> i == 0
+   LitNumWord64  -> i == 0
+   LitNumNatural -> i == 0
+   LitNumInteger -> False
+isMinBound _      _                  = False
 
 isMaxBound :: DynFlags -> Literal -> Bool
-isMaxBound _      (MachChar c)   = c == maxBound
-isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags
-isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)
-isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
-isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
-isMaxBound _      _              = False
+isMaxBound _      (MachChar c)       = c == maxBound
+isMaxBound dflags (LitNumber nt i _) = case nt of
+   LitNumInt     -> i == tARGET_MAX_INT dflags
+   LitNumInt64   -> i == toInteger (maxBound :: Int64)
+   LitNumWord    -> i == tARGET_MAX_WORD dflags
+   LitNumWord64  -> i == toInteger (maxBound :: Word64)
+   LitNumNatural -> False
+   LitNumInteger -> False
+isMaxBound _      _                  = False
 
 -- | Create an Int literal expression while ensuring the given Integer is in the
 -- target Int range
 intResult :: DynFlags -> Integer -> Maybe CoreExpr
-intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
+intResult dflags result = Just (intResult' dflags result)
+
+intResult' :: DynFlags -> Integer -> CoreExpr
+intResult' dflags result = Lit (mkMachIntWrap dflags result)
+
+-- | Create an unboxed pair of an Int literal expression, ensuring the given
+-- Integer is in the target Int range and the corresponding overflow flag
+-- (@0#@/@1#@) if it wasn't.
+intCResult :: DynFlags -> Integer -> Maybe CoreExpr
+intCResult dflags result = Just (mkPair [Lit lit, Lit c])
+  where
+    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
+    (lit, b) = mkMachIntWrapC dflags result
+    c = if b then onei dflags else zeroi dflags
 
 -- | Create a Word literal expression while ensuring the given Integer is in the
 -- target Word range
 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
-wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
+wordResult dflags result = Just (wordResult' dflags result)
+
+wordResult' :: DynFlags -> Integer -> CoreExpr
+wordResult' dflags result = Lit (mkMachWordWrap dflags result)
+
+-- | Create an unboxed pair of a Word literal expression, ensuring the given
+-- Integer is in the target Word range and the corresponding carry flag
+-- (@0#@/@1#@) if it wasn't.
+wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
+wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
+  where
+    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
+    (lit, b) = mkMachWordWrapC dflags result
+    c = if b then onei dflags else zeroi dflags
 
 inversePrimOp :: PrimOp -> RuleM CoreExpr
 inversePrimOp primop = do
@@ -649,12 +727,10 @@ instance Monad RuleM where
   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
     Nothing -> Nothing
     Just r -> runRuleM (g r) dflags iu e
-  fail _ = mzero
+  fail = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail RuleM where
     fail _ = mzero
-#endif
 
 instance Alternative RuleM where
   empty = RuleM $ \_ _ _ -> Nothing
@@ -734,6 +810,16 @@ leftIdentityDynFlags id_lit = do
   guard $ l1 == id_lit dflags
   return e2
 
+-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
+-- addition to the result, we have to indicate that no carry/overflow occured.
+leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+leftIdentityCDynFlags id_lit = do
+  dflags <- getDynFlags
+  [Lit l1, e2] <- getArgs
+  guard $ l1 == id_lit dflags
+  let no_c = Lit (zeroi dflags)
+  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
+
 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
 rightIdentityDynFlags id_lit = do
   dflags <- getDynFlags
@@ -741,8 +827,25 @@ rightIdentityDynFlags id_lit = do
   guard $ l2 == id_lit dflags
   return e1
 
+-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
+-- addition to the result, we have to indicate that no carry/overflow occured.
+rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+rightIdentityCDynFlags id_lit = do
+  dflags <- getDynFlags
+  [e1, Lit l2] <- getArgs
+  guard $ l2 == id_lit dflags
+  let no_c = Lit (zeroi dflags)
+  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
+
 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
-identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
+identityDynFlags lit =
+  leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
+
+-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
+-- to the result, we have to indicate that no carry/overflow occured.
+identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
+identityCDynFlags lit =
+  leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
 
 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
 leftZero zero = do
@@ -831,9 +934,9 @@ trueValBool   = Var trueDataConId -- see Note [What's true and false]
 falseValBool  = Var falseDataConId
 
 ltVal, eqVal, gtVal :: Expr CoreBndr
-ltVal = Var ltDataConId
-eqVal = Var eqDataConId
-gtVal = Var gtDataConId
+ltVal = Var ordLTDataConId
+eqVal = Var ordEQDataConId
+gtVal = Var ordGTDataConId
 
 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
 mkIntVal dflags i = Lit (mkMachInt dflags i)
@@ -880,7 +983,7 @@ tagToEnumRule :: RuleM CoreExpr
 -- If     data T a = A | B | C
 -- then   tag2Enum# (T ty) 2# -->  B ty
 tagToEnumRule = do
-  [Type ty, Lit (MachInt i)] <- getArgs
+  [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
   case splitTyConApp_maybe ty of
     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
       let tag = fromInteger i
@@ -893,21 +996,35 @@ tagToEnumRule = do
     _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
 
-{-
-For dataToTag#, we can reduce if either
-
-        (a) the argument is a constructor
-        (b) the argument is a variable whose unfolding is a known constructor
--}
-
+------------------------------
 dataToTagRule :: RuleM CoreExpr
+-- Rules for dataToTag#
 dataToTagRule = a `mplus` b
   where
+    -- dataToTag (tagToEnum x)   ==>   x
     a = do
       [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
       guard $ tag_to_enum `hasKey` tagToEnumKey
       guard $ ty1 `eqType` ty2
-      return tag -- dataToTag (tagToEnum x)   ==>   x
+      return tag
+
+    -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would
+    -- like to, but it seems tricky. See #14282. The trouble is that
+    -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag#
+    -- is can_fail, this expression is immediately transformed into
+    --
+    --   case dataToTag# @T x of wild
+    --     { __DEFAULT -> tagToEnum# @T wild }
+    --
+    -- and wild has no unfolding. Simon Peyton Jones speculates one way around
+    -- might be to arrange to give unfoldings to case binders of CONLIKE
+    -- applications and mark dataToTag# CONLIKE, but he doubts it's really
+    -- worth the trouble.
+
+    -- dataToTag (K e1 e2)  ==>   tag-of K
+    -- This also works (via exprIsConApp_maybe) for
+    --   dataToTag x
+    -- where x's unfolding is a constructor application
     b = do
       dflags <- getDynFlags
       [_, val_arg] <- getArgs
@@ -924,12 +1041,65 @@ dataToTagRule = a `mplus` b
 ************************************************************************
 -}
 
--- seq# :: forall a s . a -> State# s -> (# State# s, a #)
+{- Note [seq# magic]
+~~~~~~~~~~~~~~~~~~~~
+The primop
+   seq# :: forall a s . a -> State# s -> (# State# s, a #)
+
+is /not/ the same as the Prelude function seq :: a -> b -> b
+as you can see from its type.  In fact, seq# is the implementation
+mechanism for 'evaluate'
+
+   evaluate :: a -> IO a
+   evaluate a = IO $ \s -> seq# a s
+
+The semantics of seq# is
+  * evaluate its first argument
+  * and return it
+
+Things to note
+
+* Why do we need a primop at all?  That is, instead of
+      case seq# x s of (# x, s #) -> blah
+  why not instead say this?
+      case x of { DEFAULT -> blah)
+
+  Reason (see Trac #5129): if we saw
+    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
+
+  then we'd drop the 'case x' because the body of the case is bottom
+  anyway. But we don't want to do that; the whole /point/ of
+  seq#/evaluate is to evaluate 'x' first in the IO monad.
+
+  In short, we /always/ evaluate the first argument and never
+  just discard it.
+
+* Why return the value?  So that we can control sharing of seq'd
+  values: in
+     let x = e in x `seq` ... x ...
+  We don't want to inline x, so better to represent it as
+       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
+  also it matches the type of rseq in the Eval monad.
+
+Implementing seq#.  The compiler has magic for SeqOp in
+
+- PrelRules.seqRule: eliminate (seq# <whnf> s)
+
+- StgCmmExpr.cgExpr, and cgCase: special case for seq#
+
+- CoreUtils.exprOkForSpeculation;
+  see Note [seq# and expr_ok] in CoreUtils
+
+- Simplify.addEvals records evaluated-ness for the result; see
+  Note [Adding evaluatedness info to pattern-bound variables]
+  in Simplify
+-}
+
 seqRule :: RuleM CoreExpr
 seqRule = do
-  [Type ty_a, Type ty_s, a, s] <- getArgs
+  [Type ty_a, Type _ty_s, a, s] <- getArgs
   guard $ exprIsHNF a
-  return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
+  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
 
 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
 sparkRule :: RuleM CoreExpr
@@ -987,7 +1157,7 @@ builtinRules
         [ nonZeroLit 1 >> binaryLit (intOp2 div)
         , leftZero zeroi
         , do
-          [arg, Lit (MachInt d)] <- getArgs
+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
           Just n <- return $ exactLog2 d
           dflags <- getDynFlags
           return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
@@ -996,7 +1166,7 @@ builtinRules
         [ nonZeroLit 1 >> binaryLit (intOp2 mod)
         , leftZero zeroi
         , do
-          [arg, Lit (MachInt d)] <- getArgs
+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
           Just _ <- return $ exactLog2 d
           dflags <- getDynFlags
           return $ Var (mkPrimOpId AndIOp)
@@ -1004,6 +1174,10 @@ builtinRules
         ]
      ]
  ++ builtinIntegerRules
+ ++ builtinNaturalRules
+{-# NOINLINE builtinRules #-}
+-- there is no benefit to inlining these yet, despite this, GHC produces
+-- unfoldings for this regardless since the floated list entries look small.
 
 builtinIntegerRules :: [CoreRule]
 builtinIntegerRules =
@@ -1082,7 +1256,7 @@ builtinIntegerRules =
                            ru_try = match_Integer_unop op }
           rule_bitInteger str name
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
-                           ru_try = match_IntToInteger_unop (bit . fromIntegral) }
+                           ru_try = match_bitInteger }
           rule_binop str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop op }
@@ -1117,6 +1291,31 @@ builtinIntegerRules =
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_rationalTo mkLit }
 
+builtinNaturalRules :: [CoreRule]
+builtinNaturalRules =
+ [rule_binop              "plusNatural"        plusNaturalName         (+)
+ ,rule_partial_binop      "minusNatural"       minusNaturalName        (\a b -> if a >= b then Just (a - b) else Nothing)
+ ,rule_binop              "timesNatural"       timesNaturalName        (*)
+ ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
+ ,rule_NaturalToInteger   "naturalToInteger"   naturalToIntegerName
+ ,rule_WordToNatural      "wordToNatural"      wordToNaturalName
+ ]
+    where rule_binop str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Natural_binop op }
+          rule_partial_binop str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Natural_partial_binop op }
+          rule_NaturalToInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_NaturalToInteger }
+          rule_NaturalFromInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_NaturalFromInteger }
+          rule_WordToNatural str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_WordToNatural }
+
 ---------------------------------------------------
 -- The rule is this:
 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
@@ -1208,51 +1407,68 @@ match_IntToInteger = match_IntToInteger_unop id
 
 match_WordToInteger :: RuleFun
 match_WordToInteger _ id_unf id [xl]
-  | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_WordToInteger: Id has the wrong type"
 match_WordToInteger _ _ _ _ = Nothing
 
 match_Int64ToInteger :: RuleFun
 match_Int64ToInteger _ id_unf id [xl]
-  | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_Int64ToInteger: Id has the wrong type"
 match_Int64ToInteger _ _ _ _ = Nothing
 
 match_Word64ToInteger :: RuleFun
 match_Word64ToInteger _ id_unf id [xl]
-  | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_Word64ToInteger: Id has the wrong type"
 match_Word64ToInteger _ _ _ _ = Nothing
 
--------------------------------------------------
-match_Integer_convert :: Num a
-                      => (DynFlags -> a -> Expr CoreBndr)
-                      -> RuleFun
-match_Integer_convert convert dflags id_unf _ [xl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  = Just (convert dflags (fromInteger x))
-match_Integer_convert _ _ _ _ _ = Nothing
+match_NaturalToInteger :: RuleFun
+match_NaturalToInteger _ id_unf id [xl]
+  | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumInteger x naturalTy))
+    _ ->
+        panic "match_NaturalToInteger: Id has the wrong type"
+match_NaturalToInteger _ _ _ _ = Nothing
 
-match_Integer_unop :: (Integer -> Integer) -> RuleFun
-match_Integer_unop unop _ id_unf _ [xl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  = Just (Lit (LitInteger (unop x) i))
-match_Integer_unop _ _ _ _ _ = Nothing
+match_NaturalFromInteger :: RuleFun
+match_NaturalFromInteger _ id_unf id [xl]
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , x >= 0
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumNatural x naturalTy))
+    _ ->
+        panic "match_NaturalFromInteger: Id has the wrong type"
+match_NaturalFromInteger _ _ _ _ = Nothing
 
-{- Note [Rewriting bitInteger]
+match_WordToNatural :: RuleFun
+match_WordToNatural _ id_unf id [xl]
+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumNatural x naturalTy))
+    _ ->
+        panic "match_WordToNatural: Id has the wrong type"
+match_WordToNatural _ _ _ _ = Nothing
 
+-------------------------------------------------
+{- Note [Rewriting bitInteger]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For most types the bitInteger operation can be implemented in terms of shifts.
 The integer-gmp package, however, can do substantially better than this if
 allowed to provide its own implementation. However, in so doing it previously lost
@@ -1260,68 +1476,117 @@ constant-folding (see Trac #8832). The bitInteger rule above provides constant f
 specifically for this function.
 
 There is, however, a bit of trickiness here when it comes to ranges. While the
-AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
+AST encodes all integers as Integers, `bit` expects the bit
 index to be given as an Int. Hence we coerce to an Int in the rule definition.
 This will behave a bit funny for constants larger than the word size, but the user
 should expect some funniness given that they will have at very least ignored a
 warning in this case.
 -}
 
+match_bitInteger :: RuleFun
+-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
+match_bitInteger dflags id_unf fn [arg]
+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
+  , x >= 0
+  , x <= (wordSizeInBits dflags - 1)
+    -- Make sure x is small enough to yield a decently small iteger
+    -- Attempting to construct the Integer for
+    --    (bitInteger 9223372036854775807#)
+    -- would be a bad idea (Trac #14959)
+  , let x_int = fromIntegral x :: Int
+  = case splitFunTy_maybe (idType fn) of
+    Just (_, integerTy)
+      -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
+    _ -> panic "match_IntToInteger_unop: Id has the wrong type"
+
+match_bitInteger _ _ _ _ = Nothing
+
+
+-------------------------------------------------
+match_Integer_convert :: Num a
+                      => (DynFlags -> a -> Expr CoreBndr)
+                      -> RuleFun
+match_Integer_convert convert dflags id_unf _ [xl]
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  = Just (convert dflags (fromInteger x))
+match_Integer_convert _ _ _ _ _ = Nothing
+
+match_Integer_unop :: (Integer -> Integer) -> RuleFun
+match_Integer_unop unop _ id_unf _ [xl]
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  = Just (Lit (LitNumber LitNumInteger (unop x) i))
+match_Integer_unop _ _ _ _ _ = Nothing
+
 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
 match_IntToInteger_unop unop _ id_unf fn [xl]
-  | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType fn) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger (unop x) integerTy))
+        Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
     _ ->
         panic "match_IntToInteger_unop: Id has the wrong type"
 match_IntToInteger_unop _ _ _ _ _ = Nothing
 
 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
 match_Integer_binop binop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
-  = Just (Lit (LitInteger (x `binop` y) i))
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitInteger (x `binop` y) i))
 match_Integer_binop _ _ _ _ _ = Nothing
 
+match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Natural_binop binop _ id_unf _ [xl,yl]
+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitNatural (x `binop` y) i))
+match_Natural_binop _ _ _ _ _ = Nothing
+
+match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
+match_Natural_partial_binop binop _ id_unf _ [xl,yl]
+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+  , Just z <- x `binop` y
+  = Just (Lit (mkLitNatural z i))
+match_Natural_partial_binop _ _ _ _ _ = Nothing
+
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_both
    :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
 match_Integer_divop_both divop _ id_unf _ [xl,yl]
-  | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   , (r,s) <- x `divop` y
-  = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
+  = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
 match_Integer_divop_both _ _ _ _ _ = Nothing
 
 -- This helper is used for the quot and rem functions
 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
 match_Integer_divop_one divop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
-  = Just (Lit (LitInteger (x `divop` y) i))
+  = Just (Lit (mkLitInteger (x `divop` y) i))
 match_Integer_divop_one _ _ _ _ _ = Nothing
 
 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
-  = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
 match_Integer_Int_binop _ _ _ _ _ = Nothing
 
 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
 match_Integer_binop_Prim _ _ _ _ _ = Nothing
 
 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
              LT -> ltVal
              EQ -> eqVal
@@ -1332,8 +1597,8 @@ match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
                               -> RuleFun
 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
 
@@ -1351,14 +1616,14 @@ match_rationalTo :: RealFloat a
                  => (a -> Expr CoreBndr)
                  -> RuleFun
 match_rationalTo mkLit _ id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (mkLit (fromRational (x % y)))
 match_rationalTo _ _ _ _ _ = Nothing
 
 match_decodeDouble :: RuleFun
-match_decodeDouble _ id_unf fn [xl]
+match_decodeDouble dflags id_unf fn [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType fn) of
     Just (_, res)
@@ -1366,8 +1631,8 @@ match_decodeDouble _ id_unf fn [xl]
       -> case decodeFloat (fromRational x :: Double) of
            (y, z) ->
              Just $ mkCoreUbxTup [integerTy, intHashTy]
-                                 [Lit (LitInteger y integerTy),
-                                  Lit (MachInt (toInteger z))]
+                                 [Lit (mkLitInteger y integerTy),
+                                  Lit (mkMachInt dflags (toInteger z))]
     _ ->
         pprPanic "match_decodeDouble: Id has the wrong type"
           (ppr fn <+> dcolon <+> ppr (idType fn))
@@ -1388,6 +1653,275 @@ match_smallIntegerTo _ _ _ _ _ = Nothing
 
 
 --------------------------------------------------------
+-- Note [Constant folding through nested expressions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We use rewrites rules to perform constant folding. It means that we don't
+-- have a global view of the expression we are trying to optimise. As a
+-- consequence we only perform local (small-step) transformations that either:
+--    1) reduce the number of operations
+--    2) rearrange the expression to increase the odds that other rules will
+--    match
+--
+-- We don't try to handle more complex expression optimisation cases that would
+-- require a global view. For example, rewriting expressions to increase
+-- sharing (e.g., Horner's method); optimisations that require local
+-- transformations increasing the number of operations; rearrangements to
+-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
+--
+-- We already have rules to perform constant folding on expressions with the
+-- following shape (where a and/or b are literals):
+--
+--          D)    op
+--                /\
+--               /  \
+--              /    \
+--             a      b
+--
+-- To support nested expressions, we match three other shapes of expression
+-- trees:
+--
+-- A)   op1          B)       op1       C)       op1
+--      /\                    /\                 /\
+--     /  \                  /  \               /  \
+--    /    \                /    \             /    \
+--   a     op2            op2     c          op2    op3
+--          /\            /\                 /\      /\
+--         /  \          /  \               /  \    /  \
+--        b    c        a    b             a    b  c    d
+--
+--
+-- R1) +/- simplification:
+--    ops = + or -, two literals (not siblings)
+--
+--    Examples:
+--       A: 5 + (10-x)  ==> 15-x
+--       B: (10+x) + 5  ==> 15+x
+--       C: (5+a)-(5-b) ==> 0+(a+b)
+--
+-- R2) * simplification
+--    ops = *, two literals (not siblings)
+--
+--    Examples:
+--       A: 5 * (10*x)  ==> 50*x
+--       B: (10*x) * 5  ==> 50*x
+--       C: (5*a)*(5*b) ==> 25*(a*b)
+--
+-- R3) * distribution over +/-
+--    op1 = *, op2 = + or -, two literals (not siblings)
+--
+--    This transformation doesn't reduce the number of operations but switches
+--    the outer and the inner operations so that the outer is (+) or (-) instead
+--    of (*). It increases the odds that other rules will match after this one.
+--
+--    Examples:
+--       A: 5 * (10-x)  ==> 50 - (5*x)
+--       B: (10+x) * 5  ==> 50 + (5*x)
+--       C: Not supported as it would increase the number of operations:
+--          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
+--
+-- R4) Simple factorization
+--
+--    op1 = + or -, op2/op3 = *,
+--    one literal for each innermost * operation (except in the D case),
+--    the two other terms are equals
+--
+--    Examples:
+--       A: x - (10*x)  ==> (-9)*x
+--       B: (10*x) + x  ==> 11*x
+--       C: (5*x)-(x*3) ==> 2*x
+--       D: x+x         ==> 2*x
+--
+-- R5) +/- propagation
+--
+--    ops = + or -, one literal
+--
+--    This transformation doesn't reduce the number of operations but propagates
+--    the constant to the outer level. It increases the odds that other rules
+--    will match after this one.
+--
+--    Examples:
+--       A: x - (10-y)  ==> (x+y) - 10
+--       B: (10+x) - y  ==> 10 + (x-y)
+--       C: N/A (caught by the A and B cases)
+--
+--------------------------------------------------------
+
+-- | Rules to perform constant folding into nested expressions
+--
+--See Note [Constant folding through nested expressions]
+numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
+numFoldingRules op dict = do
+  [e1,e2] <- getArgs
+  dflags <- getDynFlags
+  let PrimOps{..} = dict dflags
+  if not (gopt Opt_NumConstantFolding dflags)
+    then mzero
+    else case BinOpApp e1 op e2 of
+     -- R1) +/- simplification
+     x    :++: (y :++: v)          -> return $ mkL (x+y)   `add` v
+     x    :++: (L y :-: v)         -> return $ mkL (x+y)   `sub` v
+     x    :++: (v   :-: L y)       -> return $ mkL (x-y)   `add` v
+     L x  :-:  (y :++: v)          -> return $ mkL (x-y)   `sub` v
+     L x  :-:  (L y :-: v)         -> return $ mkL (x-y)   `add` v
+     L x  :-:  (v   :-: L y)       -> return $ mkL (x+y)   `sub` v
+
+     (y :++: v)    :-: L x         -> return $ mkL (y-x)   `add` v
+     (L y :-: v)   :-: L x         -> return $ mkL (y-x)   `sub` v
+     (v   :-: L y) :-: L x         -> return $ mkL (0-y-x) `add` v
+
+     (x :++: w)  :+: (y :++: v)    -> return $ mkL (x+y)   `add` (w `add` v)
+     (w :-: L x) :+: (L y :-: v)   -> return $ mkL (y-x)   `add` (w `sub` v)
+     (w :-: L x) :+: (v   :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)
+     (L x :-: w) :+: (L y :-: v)   -> return $ mkL (x+y)   `sub` (w `add` v)
+     (L x :-: w) :+: (v   :-: L y) -> return $ mkL (x-y)   `add` (v `sub` w)
+     (w :-: L x) :+: (y :++: v)    -> return $ mkL (y-x)   `add` (w `add` v)
+     (L x :-: w) :+: (y :++: v)    -> return $ mkL (x+y)   `add` (v `sub` w)
+     (y :++: v)  :+: (w :-: L x)   -> return $ mkL (y-x)   `add` (w `add` v)
+     (y :++: v)  :+: (L x :-: w)   -> return $ mkL (x+y)   `add` (v `sub` w)
+
+     (v   :-: L y) :-: (w :-: L x) -> return $ mkL (x-y)   `add` (v `sub` w)
+     (v   :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)
+     (L y :-:   v) :-: (w :-: L x) -> return $ mkL (x+y)   `sub` (v `add` w)
+     (L y :-:   v) :-: (L x :-: w) -> return $ mkL (y-x)   `add` (w `sub` v)
+     (x :++: w)    :-: (y :++: v)  -> return $ mkL (x-y)   `add` (w `sub` v)
+     (w :-: L x)   :-: (y :++: v)  -> return $ mkL (0-y-x) `add` (w `sub` v)
+     (L x :-: w)   :-: (y :++: v)  -> return $ mkL (x-y)   `sub` (v `add` w)
+     (y :++: v)    :-: (w :-: L x) -> return $ mkL (y+x)   `add` (v `sub` w)
+     (y :++: v)    :-: (L x :-: w) -> return $ mkL (y-x)   `add` (v `add` w)
+
+     -- R2) * simplification
+     x :**: (y :**: v)             -> return $ mkL (x*y)   `mul` v
+     (x :**: w) :*: (y :**: v)     -> return $ mkL (x*y)   `mul` (w `mul` v)
+
+     -- R3) * distribution over +/-
+     x :**: (y :++: v)             -> return $ mkL (x*y)   `add` (mkL x `mul` v)
+     x :**: (L y :-: v)            -> return $ mkL (x*y)   `sub` (mkL x `mul` v)
+     x :**: (v   :-: L y)          -> return $ (mkL x `mul` v) `sub` mkL (x*y)
+
+     -- R4) Simple factorization
+     v :+: w
+      | w `cheapEqExpr` v          -> return $ mkL 2       `mul` v
+     w :+: (y :**: v)
+      | w `cheapEqExpr` v          -> return $ mkL (1+y)   `mul` v
+     w :-: (y :**: v)
+      | w `cheapEqExpr` v          -> return $ mkL (1-y)   `mul` v
+     (y :**: v) :+: w
+      | w `cheapEqExpr` v          -> return $ mkL (y+1)   `mul` v
+     (y :**: v) :-: w
+      | w `cheapEqExpr` v          -> return $ mkL (y-1)   `mul` v
+     (x :**: w) :+: (y :**: v)
+      | w `cheapEqExpr` v          -> return $ mkL (x+y)   `mul` v
+     (x :**: w) :-: (y :**: v)
+      | w `cheapEqExpr` v          -> return $ mkL (x-y)   `mul` v
+
+     -- R5) +/- propagation
+     w  :+: (y :++: v)             -> return $ mkL y `add` (w `add` v)
+     (y :++: v) :+: w              -> return $ mkL y       `add` (w `add` v)
+     w  :-: (y :++: v)             -> return $ (w `sub` v) `sub` mkL y
+     (y :++: v) :-: w              -> return $ mkL y       `add` (v `sub` w)
+     w    :-: (L y :-: v)          -> return $ (w `add` v) `sub` mkL y
+     (L y :-: v) :-: w             -> return $ mkL y       `sub` (w `add` v)
+     w    :+: (L y :-: v)          -> return $ mkL y       `add` (w `sub` v)
+     w    :+: (v :-: L y)          -> return $ (w `add` v) `sub` mkL y
+     (L y :-: v) :+: w             -> return $ mkL y       `add` (w `sub` v)
+     (v :-: L y) :+: w             -> return $ (w `add` v) `sub` mkL y
+
+     _                             -> mzero
+
+
+
+-- | Match the application of a binary primop
+pattern BinOpApp  :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
+pattern BinOpApp  x op y =  OpVal op `App` x `App` y
+
+-- | Match a primop
+pattern OpVal   :: PrimOp  -> Arg CoreBndr
+pattern OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where
+   OpVal op = Var (mkPrimOpId op)
+
+
+
+-- | Match a literal
+pattern L :: Integer -> Arg CoreBndr
+pattern L l <- Lit (isLitValue_maybe -> Just l)
+
+-- | Match an addition
+pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :+: y <- BinOpApp x (isAddOp -> True) y
+
+-- | Match an addition with a literal (handle commutativity)
+pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr
+pattern l :++: x <- (isAdd -> Just (l,x))
+
+isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)
+isAdd e = case e of
+   L l :+: x   -> Just (l,x)
+   x   :+: L l -> Just (l,x)
+   _           -> Nothing
+
+-- | Match a multiplication
+pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :*: y <- BinOpApp x (isMulOp -> True) y
+
+-- | Match a multiplication with a literal (handle commutativity)
+pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr
+pattern l :**: x <- (isMul -> Just (l,x))
+
+isMul :: CoreExpr -> Maybe (Integer,CoreExpr)
+isMul e = case e of
+   L l :*: x   -> Just (l,x)
+   x   :*: L l -> Just (l,x)
+   _           -> Nothing
+
+
+-- | Match a subtraction
+pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
+pattern x :-: y <- BinOpApp x (isSubOp -> True) y
+
+isSubOp :: PrimOp -> Bool
+isSubOp IntSubOp  = True
+isSubOp WordSubOp = True
+isSubOp _         = False
+
+isAddOp :: PrimOp -> Bool
+isAddOp IntAddOp  = True
+isAddOp WordAddOp = True
+isAddOp _         = False
+
+isMulOp :: PrimOp -> Bool
+isMulOp IntMulOp  = True
+isMulOp WordMulOp = True
+isMulOp _         = False
+
+-- | Explicit "type-class"-like dictionary for numeric primops
+--
+-- Depends on DynFlags because creating a literal value depends on DynFlags
+data PrimOps = PrimOps
+   { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers
+   , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers
+   , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers
+   , mkL :: Integer -> CoreExpr              -- ^ Create a literal value
+   }
+
+intPrimOps :: DynFlags -> PrimOps
+intPrimOps dflags = PrimOps
+   { add = \x y -> BinOpApp x IntAddOp y
+   , sub = \x y -> BinOpApp x IntSubOp y
+   , mul = \x y -> BinOpApp x IntMulOp y
+   , mkL = intResult' dflags
+   }
+
+wordPrimOps :: DynFlags -> PrimOps
+wordPrimOps dflags = PrimOps
+   { add = \x y -> BinOpApp x WordAddOp y
+   , sub = \x y -> BinOpApp x WordSubOp y
+   , mul = \x y -> BinOpApp x WordMulOp y
+   , mkL = wordResult' dflags
+   }
+
+
+--------------------------------------------------------
 -- Constant folding through case-expressions
 --
 -- cf Scrutinee Constant Folding in simplCore/SimplUtils
@@ -1396,11 +1930,13 @@ match_smallIntegerTo _ _ _ _ _ = Nothing
 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
 -- function to apply to each literal alternative.
 caseRules :: DynFlags
-          -> CoreExpr                    -- Scrutinee
-          -> Maybe ( CoreExpr            -- New scrutinee
-                   , AltCon -> AltCon    -- How to fix up the alt pattern
-                   , Id -> CoreExpr)     -- How to reconstruct the original scrutinee
-                                         -- from the new case-binder
+          -> CoreExpr                       -- Scrutinee
+          -> Maybe ( CoreExpr               -- New scrutinee
+                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern
+                                            --   Nothing <=> Unreachable
+                                            -- See Note [Unreachable caseRules alternatives]
+                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee
+                                            -- from the new case-binder
 -- e.g  case e of b {
 --         ...;
 --         con bs -> rhs;
@@ -1423,7 +1959,7 @@ caseRules dflags (App (App (Var f) (Lit l)) v)   -- x# `op` v
   , Just x  <- isLitValue_maybe l
   , Just adjust_lit <- adjustDyadicLeft x op
   = Just (v, tx_lit_con dflags adjust_lit
-           , \v -> (App (App (Var f) (Var v)) (Lit l)))
+           , \v -> (App (App (Var f) (Lit l)) (Var v)))
 
 
 caseRules dflags (App (Var f) v              )   -- op v
@@ -1441,15 +1977,17 @@ caseRules dflags (App (App (Var f) type_arg) v)
 -- See Note [caseRules for dataToTag]
 caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x
   | Just DataToTagOp <- isPrimOpId_maybe f
+  , Just (tc, _) <- tcSplitTyConApp_maybe ty
+  , isAlgTyCon tc
   = Just (v, tx_con_dtt ty
            , \v -> App (App (Var f) (Type ty)) (Var v))
 
 caseRules _ _ = Nothing
 
 
-tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon
-tx_lit_con _      _      DEFAULT    = DEFAULT
-tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l)
+tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
+tx_lit_con _      _      DEFAULT    = Just DEFAULT
+tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l)
 tx_lit_con _      _      alt        = pprPanic "caseRules" (ppr alt)
    -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
    -- literal alternatives remain in Word/Int target ranges
@@ -1489,22 +2027,28 @@ adjustUnary op
          IntNegOp  -> Just (\y -> negate y    )
          _         -> Nothing
 
-tx_con_tte :: DynFlags -> AltCon -> AltCon
-tx_con_tte _      DEFAULT      = DEFAULT
-tx_con_tte dflags (DataAlt dc)
-  | tag == 0  = DEFAULT   -- See Note [caseRules for tagToEnum]
-  | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
-  where
-    tag = dataConTagZ dc
-tx_con_tte _      alt          = pprPanic "caseRules" (ppr alt)
+tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
+tx_con_tte _      DEFAULT         = Just DEFAULT
+tx_con_tte _      alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
+tx_con_tte dflags (DataAlt dc)  -- See Note [caseRules for tagToEnum]
+  = Just $ LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc
+
+tx_con_dtt :: Type -> AltCon -> Maybe AltCon
+tx_con_dtt _  DEFAULT = Just DEFAULT
+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
+   | tag >= 0
+   , tag < n_data_cons
+   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)
+   | otherwise
+   = Nothing
+   where
+     tag         = fromInteger i :: ConTagZ
+     tc          = tyConAppTyCon ty
+     n_data_cons = tyConFamilySize tc
+     data_cons   = tyConDataCons tc
+
+tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
 
-tx_con_dtt :: Type -> AltCon -> AltCon
-tx_con_dtt _  DEFAULT              = DEFAULT
-tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
-tx_con_dtt _  alt                  = pprPanic "caseRules" (ppr alt)
-
-get_con :: Type -> ConTagZ -> DataCon
-get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag
 
 {- Note [caseRules for tagToEnum]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1515,18 +2059,34 @@ We want to transform
 into
    case x of
      0# -> e1
-     1# -> e1
+     1# -> e2
 
-This rule elimiantes a lot of boilerplate. For
-  if (x>y) then e1 else e2
+This rule eliminates a lot of boilerplate. For
+  if (x>y) then e2 else e1
 we generate
   case tagToEnum (x ># y) of
-    False -> e2
-    True  -> e1
+    False -> e1
+    True  -> e2
 and it is nice to then get rid of the tagToEnum.
 
-NB: in SimplUtils, where we invoke caseRules,
-    we convert that 0# to DEFAULT
+Beware (Trac #14768): avoid the temptation to map constructor 0 to
+DEFAULT, in the hope of getting this
+  case (x ># y) of
+    DEFAULT -> e1
+    1#      -> e2
+That fails utterly in the case of
+   data Colour = Red | Green | Blue
+   case tagToEnum x of
+      DEFAULT -> e1
+      Red     -> e2
+
+We don't want to get this!
+   case x of
+      DEFAULT -> e1
+      DEFAULT -> e2
+
+Instead, we deal with turning one branch into DEFAULT in SimplUtils
+(add_default in mkCase3).
 
 Note [caseRules for dataToTag]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1541,4 +2101,25 @@ into
 
 Note the need for some wildcard binders in
 the 'cons' case.
+
+For the time, we only apply this transformation when the type of `x` is a type
+headed by a normal tycon. In particular, we do not apply this in the case of a
+data family tycon, since that would require carefully applying coercion(s)
+between the data family and the data family instance's representation type,
+which caseRules isn't currently engineered to handle (#14680).
+
+Note [Unreachable caseRules alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Take care if we see something like
+  case dataToTag x of
+    DEFAULT -> e1
+    -1# -> e2
+    100 -> e3
+because there isn't a data constructor with tag -1 or 100. In this case the
+out-of-range alterantive is dead code -- we know the range of tags for x.
+
+Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
+an alternative that is unreachable.
+
+You may wonder how this can happen: check out Trac #15436.
 -}
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index 3a849060ff..4eb94e9fdb 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -7,9 +7,7 @@
 {-# LANGUAGE CPP #-}
 
 -- The default is a bit too low for the quite large primOpInfo definition
-#if __GLASGOW_HASKELL__ >= 801
 {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-#endif
 
 module PrimOp (
         PrimOp(..), PrimOpVecCat(..), allThePrimOps,
@@ -29,6 +27,8 @@ module PrimOp (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TysPrim
 import TysWiredIn
 
diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot
index 6b92ef3d49..f10ef44972 100644
--- a/compiler/prelude/PrimOp.hs-boot
+++ b/compiler/prelude/PrimOp.hs-boot
@@ -1,3 +1,5 @@
 module PrimOp where
 
+import GhcPrelude ()
+
 data PrimOp
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 85362434cc..7183a7edd6 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -6,6 +6,8 @@
 
 module THNames where
 
+import GhcPrelude ()
+
 import PrelNames( mk_known_key_name )
 import Module( Module, mkModuleNameFS, mkModule, thUnitId )
 import Name( Name )
@@ -51,10 +53,10 @@ templateHaskellNames = [
     varEName, conEName, litEName, appEName, appTypeEName, infixEName,
     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName, unboxedSumEName,
-    condEName, multiIfEName, letEName, caseEName, doEName, compEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
-    labelEName,
+    labelEName, implicitParamVarEName,
     -- FieldExp
     fieldExpName,
     -- Body
@@ -62,7 +64,7 @@ templateHaskellNames = [
     -- Guard
     normalGEName, patGEName,
     -- Stmt
-    bindSName, letSName, noBindSName, parSName,
+    bindSName, letSName, noBindSName, parSName, recSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
     classDName, instanceWithOverlapDName,
@@ -73,6 +75,7 @@ templateHaskellNames = [
     dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName,
     roleAnnotDName, patSynDName, patSynSigDName,
+    implicitParamBindDName,
     -- Cxt
     cxtName,
 
@@ -95,9 +98,9 @@ templateHaskellNames = [
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, unboxedSumTName,
-    arrowTName, listTName, sigTName, sigTDataConName, litTName,
+    arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName,
+    wildCardTName, implicitParamTName,
     -- TyLit
     numTyLitName, strTyLitName,
     -- TyVarBndr
@@ -127,16 +130,14 @@ templateHaskellNames = [
     overlappableDataConName, overlappingDataConName, overlapsDataConName,
     incoherentDataConName,
     -- DerivStrategy
-    stockStrategyDataConName, anyclassStrategyDataConName,
-    newtypeStrategyDataConName,
+    stockStrategyName, anyclassStrategyName,
+    newtypeStrategyName, viaStrategyName,
     -- TExp
     tExpDataConName,
     -- RuleBndr
     ruleVarName, typedRuleVarName,
     -- FunDep
     funDepName,
-    -- FamFlavour
-    typeFamName, dataFamName,
     -- TySynEqn
     tySynEqnName,
     -- AnnTarget
@@ -152,18 +153,18 @@ templateHaskellNames = [
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
     stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
     varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
-    typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
+    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
     predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
-    roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
-    overlapTyConName, derivClauseQTyConName, derivStrategyTyConName,
+    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
+    overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
 
     -- Quasiquoting
     quoteDecName, quoteTypeName, quoteExpName, quotePatName]
 
 thSyn, thLib, qqLib :: Module
 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
 
 mkTHModule :: FastString -> Module
@@ -184,9 +185,8 @@ liftClassName = thCls (fsLit "Lift") liftClassKey
 
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
-    tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
-    predTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
-    overlapTyConName, derivStrategyTyConName :: Name
+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
+    tExpTyConName, injAnnTyConName, overlapTyConName :: Name
 qTyConName             = thTc (fsLit "Q")              qTyConKey
 nameTyConName          = thTc (fsLit "Name")           nameTyConKey
 fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey
@@ -195,16 +195,13 @@ fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey
 expTyConName           = thTc (fsLit "Exp")            expTyConKey
 decTyConName           = thTc (fsLit "Dec")            decTyConKey
 typeTyConName          = thTc (fsLit "Type")           typeTyConKey
-tyVarBndrTyConName     = thTc (fsLit "TyVarBndr")      tyVarBndrTyConKey
 matchTyConName         = thTc (fsLit "Match")          matchTyConKey
 clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
 funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
 predTyConName          = thTc (fsLit "Pred")           predTyConKey
 tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey
 injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
-kindTyConName          = thTc (fsLit "Kind")           kindTyConKey
 overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
-derivStrategyTyConName = thTc (fsLit "DerivStrategy")  derivStrategyTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
@@ -279,43 +276,45 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
-    caseEName, doEName, compEName, staticEName, unboundVarEName,
-    labelEName :: Name
-varEName        = libFun (fsLit "varE")        varEIdKey
-conEName        = libFun (fsLit "conE")        conEIdKey
-litEName        = libFun (fsLit "litE")        litEIdKey
-appEName        = libFun (fsLit "appE")        appEIdKey
-appTypeEName    = libFun (fsLit "appTypeE")    appTypeEIdKey
-infixEName      = libFun (fsLit "infixE")      infixEIdKey
-infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
-sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
-sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
-lamEName        = libFun (fsLit "lamE")        lamEIdKey
-lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
-tupEName        = libFun (fsLit "tupE")        tupEIdKey
-unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
-unboxedSumEName = libFun (fsLit "unboxedSumE") unboxedSumEIdKey
-condEName       = libFun (fsLit "condE")       condEIdKey
-multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey
-letEName        = libFun (fsLit "letE")        letEIdKey
-caseEName       = libFun (fsLit "caseE")       caseEIdKey
-doEName         = libFun (fsLit "doE")         doEIdKey
-compEName       = libFun (fsLit "compE")       compEIdKey
+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName :: Name
+varEName              = libFun (fsLit "varE")              varEIdKey
+conEName              = libFun (fsLit "conE")              conEIdKey
+litEName              = libFun (fsLit "litE")              litEIdKey
+appEName              = libFun (fsLit "appE")              appEIdKey
+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey
+infixEName            = libFun (fsLit "infixE")            infixEIdKey
+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey
+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey
+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey
+lamEName              = libFun (fsLit "lamE")              lamEIdKey
+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey
+tupEName              = libFun (fsLit "tupE")              tupEIdKey
+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey
+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey
+condEName             = libFun (fsLit "condE")             condEIdKey
+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey
+letEName              = libFun (fsLit "letE")              letEIdKey
+caseEName             = libFun (fsLit "caseE")             caseEIdKey
+doEName               = libFun (fsLit "doE")               doEIdKey
+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey
+compEName             = libFun (fsLit "compE")             compEIdKey
 -- ArithSeq skips a level
 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
-fromEName       = libFun (fsLit "fromE")       fromEIdKey
-fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey
-fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey
-fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
+fromEName             = libFun (fsLit "fromE")             fromEIdKey
+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey
+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey
+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey
 -- end ArithSeq
 listEName, sigEName, recConEName, recUpdEName :: Name
-listEName       = libFun (fsLit "listE")       listEIdKey
-sigEName        = libFun (fsLit "sigE")        sigEIdKey
-recConEName     = libFun (fsLit "recConE")     recConEIdKey
-recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
-staticEName     = libFun (fsLit "staticE")     staticEIdKey
-unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
-labelEName      = libFun (fsLit "labelE")      labelEIdKey
+listEName             = libFun (fsLit "listE")             listEIdKey
+sigEName              = libFun (fsLit "sigE")              sigEIdKey
+recConEName           = libFun (fsLit "recConE")           recConEIdKey
+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey
+staticEName           = libFun (fsLit "staticE")           staticEIdKey
+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
+labelEName            = libFun (fsLit "labelE")            labelEIdKey
+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -332,11 +331,12 @@ normalGEName = libFun (fsLit "normalGE") normalGEIdKey
 patGEName    = libFun (fsLit "patGE")    patGEIdKey
 
 -- data Stmt = ...
-bindSName, letSName, noBindSName, parSName :: Name
+bindSName, letSName, noBindSName, parSName, recSName :: Name
 bindSName   = libFun (fsLit "bindS")   bindSIdKey
 letSName    = libFun (fsLit "letS")    letSIdKey
 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
 parSName    = libFun (fsLit "parS")    parSIdKey
+recSName    = libFun (fsLit "recS")    recSIdKey
 
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
@@ -346,39 +346,38 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
-    pragCompleteDName :: Name
-funDName             = libFun (fsLit "funD")              funDIdKey
-valDName             = libFun (fsLit "valD")              valDIdKey
-dataDName            = libFun (fsLit "dataD")             dataDIdKey
-newtypeDName         = libFun (fsLit "newtypeD")          newtypeDIdKey
-tySynDName           = libFun (fsLit "tySynD")            tySynDIdKey
-classDName           = libFun (fsLit "classD")            classDIdKey
-instanceWithOverlapDName
-  = libFun (fsLit "instanceWithOverlapD")              instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun
-        (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
-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
-pragSpecInlDName     = libFun (fsLit "pragSpecInlD")      pragSpecInlDIdKey
-pragSpecInstDName    = libFun (fsLit "pragSpecInstD")     pragSpecInstDIdKey
-pragRuleDName        = libFun (fsLit "pragRuleD")         pragRuleDIdKey
-pragCompleteDName    = libFun (fsLit "pragCompleteD")     pragCompleteDIdKey
-pragAnnDName         = libFun (fsLit "pragAnnD")          pragAnnDIdKey
-dataInstDName        = libFun (fsLit "dataInstD")         dataInstDIdKey
-newtypeInstDName     = libFun (fsLit "newtypeInstD")      newtypeInstDIdKey
-tySynInstDName       = libFun (fsLit "tySynInstD")        tySynInstDIdKey
-openTypeFamilyDName  = libFun (fsLit "openTypeFamilyD")   openTypeFamilyDIdKey
-closedTypeFamilyDName= libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey
-dataFamilyDName      = libFun (fsLit "dataFamilyD")       dataFamilyDIdKey
-infixLDName          = libFun (fsLit "infixLD")           infixLDIdKey
-infixRDName          = libFun (fsLit "infixRD")           infixRDIdKey
-infixNDName          = libFun (fsLit "infixND")           infixNDIdKey
-roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey
-patSynDName          = libFun (fsLit "patSynD")           patSynDIdKey
-patSynSigDName       = libFun (fsLit "patSynSigD")        patSynSigDIdKey
+    pragCompleteDName, implicitParamBindDName :: Name
+funDName                         = libFun (fsLit "funD")                         funDIdKey
+valDName                         = libFun (fsLit "valD")                         valDIdKey
+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey
+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
+classDName                       = libFun (fsLit "classD")                       classDIdKey
+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+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
+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey
+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey
+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey
+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey
+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey
+infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey
+infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey
+infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey
+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -432,9 +431,9 @@ recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName,
     unboxedSumTName, arrowTName, listTName, appTName, sigTName,
-    sigTDataConName, equalityTName, litTName, promotedTName,
+    equalityTName, litTName, promotedTName,
     promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName :: Name
+    wildCardTName, implicitParamTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
 varTName            = libFun (fsLit "varT")           varTIdKey
 conTName            = libFun (fsLit "conT")           conTIdKey
@@ -445,9 +444,6 @@ arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
 listTName           = libFun (fsLit "listT")          listTIdKey
 appTName            = libFun (fsLit "appT")           appTIdKey
 sigTName            = libFun (fsLit "sigT")           sigTIdKey
--- Yes, we need names for both the monadic sigT as well as the pure SigT. Why?
--- Refer to the documentation for repLKind in DsMeta.
-sigTDataConName     = thCon  (fsLit "SigT")           sigTDataConKey
 equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
 litTName            = libFun (fsLit "litT")           litTIdKey
 promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
@@ -455,6 +451,7 @@ promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
 promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
 promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
 wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
 
 -- data TyLit = ...
 numTyLitName, strTyLitName :: Name
@@ -463,8 +460,8 @@ strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
 
 -- data TyVarBndr = ...
 plainTVName, kindedTVName :: Name
-plainTVName       = libFun (fsLit "plainTV")       plainTVIdKey
-kindedTVName      = libFun (fsLit "kindedTV")      kindedTVIdKey
+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
 
 -- data Role = ...
 nominalRName, representationalRName, phantomRName, inferRName :: Name
@@ -487,9 +484,9 @@ constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
 
 -- data FamilyResultSig = ...
 noSigName, kindSigName, tyVarSigName :: Name
-noSigName       = libFun (fsLit "noSig")        noSigIdKey
-kindSigName     = libFun (fsLit "kindSig")      kindSigIdKey
-tyVarSigName    = libFun (fsLit "tyVarSig")     tyVarSigIdKey
+noSigName    = libFun (fsLit "noSig")    noSigIdKey
+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey
+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
 
 -- data InjectivityAnn = ...
 injectivityAnnName :: Name
@@ -522,11 +519,6 @@ typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
 funDepName :: Name
 funDepName     = libFun (fsLit "funDep") funDepIdKey
 
--- data FamFlavour = ...
-typeFamName, dataFamName :: Name
-typeFamName = libFun (fsLit "typeFam") typeFamIdKey
-dataFamName = libFun (fsLit "dataFam") dataFamIdKey
-
 -- data TySynEqn = ...
 tySynEqnName :: Name
 tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
@@ -541,12 +533,21 @@ moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
 derivClauseName :: Name
 derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
 
+-- data DerivStrategy = ...
+stockStrategyName, anyclassStrategyName, newtypeStrategyName,
+  viaStrategyName :: Name
+stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey
+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
+newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey
+viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey
+
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, bangTypeQTyConName,
     varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
     ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
-    derivClauseQTyConName :: Name
+    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
+    derivStrategyQTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
 clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
 expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
@@ -565,6 +566,9 @@ ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
 tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
 roleTyConName           = libTc (fsLit "Role")           roleTyConKey
 derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey
+kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey
+tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey
+derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -600,13 +604,6 @@ overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey
 overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey
 incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey
 
--- data DerivStrategy = ...
-stockStrategyDataConName, anyclassStrategyDataConName,
-  newtypeStrategyDataConName :: Name
-stockStrategyDataConName    = thCon (fsLit "StockStrategy")    stockDataConKey
-anyclassStrategyDataConName = thCon (fsLit "AnyclassStrategy") anyclassDataConKey
-newtypeStrategyDataConName  = thCon (fsLit "NewtypeStrategy")  newtypeDataConKey
-
 {- *********************************************************************
 *                                                                      *
                      Class keys
@@ -630,13 +627,13 @@ liftClassKey = mkPreludeClassUnique 200
 
 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
-    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
-    decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
     predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
-    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
-    overlapTyConKey, derivClauseQTyConKey, derivStrategyTyConKey :: Unique
+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
+    overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
 matchTyConKey           = mkPreludeTyConUnique 201
 clauseTyConKey          = mkPreludeTyConUnique 202
@@ -662,17 +659,17 @@ fieldExpQTyConKey       = mkPreludeTyConUnique 221
 funDepTyConKey          = mkPreludeTyConUnique 222
 predTyConKey            = mkPreludeTyConUnique 223
 predQTyConKey           = mkPreludeTyConUnique 224
-tyVarBndrTyConKey       = mkPreludeTyConUnique 225
+tyVarBndrQTyConKey      = mkPreludeTyConUnique 225
 decsQTyConKey           = mkPreludeTyConUnique 226
 ruleBndrQTyConKey       = mkPreludeTyConUnique 227
 tySynEqnQTyConKey       = mkPreludeTyConUnique 228
 roleTyConKey            = mkPreludeTyConUnique 229
 tExpTyConKey            = mkPreludeTyConUnique 230
 injAnnTyConKey          = mkPreludeTyConUnique 231
-kindTyConKey            = mkPreludeTyConUnique 232
+kindQTyConKey           = mkPreludeTyConUnique 232
 overlapTyConKey         = mkPreludeTyConUnique 233
 derivClauseQTyConKey    = mkPreludeTyConUnique 234
-derivStrategyTyConKey   = mkPreludeTyConUnique 235
+derivStrategyQTyConKey  = mkPreludeTyConUnique 235
 
 {- *********************************************************************
 *                                                                      *
@@ -714,12 +711,6 @@ overlappingDataConKey  = mkPreludeDataConUnique 210
 overlapsDataConKey     = mkPreludeDataConUnique 211
 incoherentDataConKey   = mkPreludeDataConUnique 212
 
--- data DerivStrategy = ...
-stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique
-stockDataConKey    = mkPreludeDataConUnique 213
-anyclassDataConKey = mkPreludeDataConUnique 214
-newtypeDataConKey  = mkPreludeDataConUnique 215
-
 {- *********************************************************************
 *                                                                      *
                      Id keys
@@ -807,38 +798,40 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
-    unboundVarEIdKey, labelEIdKey :: Unique
-varEIdKey         = mkPreludeMiscIdUnique 270
-conEIdKey         = mkPreludeMiscIdUnique 271
-litEIdKey         = mkPreludeMiscIdUnique 272
-appEIdKey         = mkPreludeMiscIdUnique 273
-appTypeEIdKey     = mkPreludeMiscIdUnique 274
-infixEIdKey       = mkPreludeMiscIdUnique 275
-infixAppIdKey     = mkPreludeMiscIdUnique 276
-sectionLIdKey     = mkPreludeMiscIdUnique 277
-sectionRIdKey     = mkPreludeMiscIdUnique 278
-lamEIdKey         = mkPreludeMiscIdUnique 279
-lamCaseEIdKey     = mkPreludeMiscIdUnique 280
-tupEIdKey         = mkPreludeMiscIdUnique 281
-unboxedTupEIdKey  = mkPreludeMiscIdUnique 282
-unboxedSumEIdKey  = mkPreludeMiscIdUnique 283
-condEIdKey        = mkPreludeMiscIdUnique 284
-multiIfEIdKey     = mkPreludeMiscIdUnique 285
-letEIdKey         = mkPreludeMiscIdUnique 286
-caseEIdKey        = mkPreludeMiscIdUnique 287
-doEIdKey          = mkPreludeMiscIdUnique 288
-compEIdKey        = mkPreludeMiscIdUnique 289
-fromEIdKey        = mkPreludeMiscIdUnique 290
-fromThenEIdKey    = mkPreludeMiscIdUnique 291
-fromToEIdKey      = mkPreludeMiscIdUnique 292
-fromThenToEIdKey  = mkPreludeMiscIdUnique 293
-listEIdKey        = mkPreludeMiscIdUnique 294
-sigEIdKey         = mkPreludeMiscIdUnique 295
-recConEIdKey      = mkPreludeMiscIdUnique 296
-recUpdEIdKey      = mkPreludeMiscIdUnique 297
-staticEIdKey      = mkPreludeMiscIdUnique 298
-unboundVarEIdKey  = mkPreludeMiscIdUnique 299
-labelEIdKey       = mkPreludeMiscIdUnique 300
+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+varEIdKey              = mkPreludeMiscIdUnique 270
+conEIdKey              = mkPreludeMiscIdUnique 271
+litEIdKey              = mkPreludeMiscIdUnique 272
+appEIdKey              = mkPreludeMiscIdUnique 273
+appTypeEIdKey          = mkPreludeMiscIdUnique 274
+infixEIdKey            = mkPreludeMiscIdUnique 275
+infixAppIdKey          = mkPreludeMiscIdUnique 276
+sectionLIdKey          = mkPreludeMiscIdUnique 277
+sectionRIdKey          = mkPreludeMiscIdUnique 278
+lamEIdKey              = mkPreludeMiscIdUnique 279
+lamCaseEIdKey          = mkPreludeMiscIdUnique 280
+tupEIdKey              = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey       = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey       = mkPreludeMiscIdUnique 283
+condEIdKey             = mkPreludeMiscIdUnique 284
+multiIfEIdKey          = mkPreludeMiscIdUnique 285
+letEIdKey              = mkPreludeMiscIdUnique 286
+caseEIdKey             = mkPreludeMiscIdUnique 287
+doEIdKey               = mkPreludeMiscIdUnique 288
+compEIdKey             = mkPreludeMiscIdUnique 289
+fromEIdKey             = mkPreludeMiscIdUnique 290
+fromThenEIdKey         = mkPreludeMiscIdUnique 291
+fromToEIdKey           = mkPreludeMiscIdUnique 292
+fromThenToEIdKey       = mkPreludeMiscIdUnique 293
+listEIdKey             = mkPreludeMiscIdUnique 294
+sigEIdKey              = mkPreludeMiscIdUnique 295
+recConEIdKey           = mkPreludeMiscIdUnique 296
+recUpdEIdKey           = mkPreludeMiscIdUnique 297
+staticEIdKey           = mkPreludeMiscIdUnique 298
+unboundVarEIdKey       = mkPreludeMiscIdUnique 299
+labelEIdKey            = mkPreludeMiscIdUnique 300
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
+mdoEIdKey              = mkPreludeMiscIdUnique 302
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
@@ -855,11 +848,12 @@ normalGEIdKey     = mkPreludeMiscIdUnique 308
 patGEIdKey        = mkPreludeMiscIdUnique 309
 
 -- data Stmt = ...
-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
 bindSIdKey       = mkPreludeMiscIdUnique 310
 letSIdKey        = mkPreludeMiscIdUnique 311
 noBindSIdKey     = mkPreludeMiscIdUnique 312
 parSIdKey        = mkPreludeMiscIdUnique 313
+recSIdKey        = mkPreludeMiscIdUnique 314
 
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
@@ -869,7 +863,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
-    patSynSigDIdKey, pragCompleteDIdKey :: Unique
+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
 funDIdKey                         = mkPreludeMiscIdUnique 320
 valDIdKey                         = mkPreludeMiscIdUnique 321
 dataDIdKey                        = mkPreludeMiscIdUnique 322
@@ -901,144 +895,140 @@ defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
 patSynDIdKey                      = mkPreludeMiscIdUnique 348
 patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
 pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
 
 -- type Cxt = ...
 cxtIdKey :: Unique
-cxtIdKey               = mkPreludeMiscIdUnique 351
+cxtIdKey               = mkPreludeMiscIdUnique 361
 
 -- data SourceUnpackedness = ...
 noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
-noSourceUnpackednessKey = mkPreludeMiscIdUnique 352
-sourceNoUnpackKey       = mkPreludeMiscIdUnique 353
-sourceUnpackKey         = mkPreludeMiscIdUnique 354
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363
+sourceUnpackKey         = mkPreludeMiscIdUnique 364
 
 -- data SourceStrictness = ...
 noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
-noSourceStrictnessKey   = mkPreludeMiscIdUnique 355
-sourceLazyKey           = mkPreludeMiscIdUnique 356
-sourceStrictKey         = mkPreludeMiscIdUnique 357
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365
+sourceLazyKey           = mkPreludeMiscIdUnique 366
+sourceStrictKey         = mkPreludeMiscIdUnique 367
 
 -- data Con = ...
 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
   recGadtCIdKey :: Unique
-normalCIdKey      = mkPreludeMiscIdUnique 358
-recCIdKey         = mkPreludeMiscIdUnique 359
-infixCIdKey       = mkPreludeMiscIdUnique 360
-forallCIdKey      = mkPreludeMiscIdUnique 361
-gadtCIdKey        = mkPreludeMiscIdUnique 362
-recGadtCIdKey     = mkPreludeMiscIdUnique 363
+normalCIdKey      = mkPreludeMiscIdUnique 368
+recCIdKey         = mkPreludeMiscIdUnique 369
+infixCIdKey       = mkPreludeMiscIdUnique 370
+forallCIdKey      = mkPreludeMiscIdUnique 371
+gadtCIdKey        = mkPreludeMiscIdUnique 372
+recGadtCIdKey     = mkPreludeMiscIdUnique 373
 
 -- data Bang = ...
 bangIdKey :: Unique
-bangIdKey         = mkPreludeMiscIdUnique 364
+bangIdKey         = mkPreludeMiscIdUnique 374
 
 -- type BangType = ...
 bangTKey :: Unique
-bangTKey          = mkPreludeMiscIdUnique 365
+bangTKey          = mkPreludeMiscIdUnique 375
 
 -- type VarBangType = ...
 varBangTKey :: Unique
-varBangTKey       = mkPreludeMiscIdUnique 366
+varBangTKey       = mkPreludeMiscIdUnique 376
 
 -- data PatSynDir = ...
 unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
-unidirPatSynIdKey    = mkPreludeMiscIdUnique 367
-implBidirPatSynIdKey = mkPreludeMiscIdUnique 368
-explBidirPatSynIdKey = mkPreludeMiscIdUnique 369
+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
 
 -- data PatSynArgs = ...
 prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
-prefixPatSynIdKey = mkPreludeMiscIdUnique 370
-infixPatSynIdKey  = mkPreludeMiscIdUnique 371
-recordPatSynIdKey = mkPreludeMiscIdUnique 372
+prefixPatSynIdKey = mkPreludeMiscIdUnique 380
+infixPatSynIdKey  = mkPreludeMiscIdUnique 381
+recordPatSynIdKey = mkPreludeMiscIdUnique 382
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
     unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
-    sigTDataConKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+    equalityTIdKey, litTIdKey, promotedTIdKey,
     promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
-    wildCardTIdKey :: Unique
-forallTIdKey        = mkPreludeMiscIdUnique 381
-varTIdKey           = mkPreludeMiscIdUnique 382
-conTIdKey           = mkPreludeMiscIdUnique 383
-tupleTIdKey         = mkPreludeMiscIdUnique 384
-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 385
-unboxedSumTIdKey    = mkPreludeMiscIdUnique 386
-arrowTIdKey         = mkPreludeMiscIdUnique 387
-listTIdKey          = mkPreludeMiscIdUnique 388
-appTIdKey           = mkPreludeMiscIdUnique 389
-sigTIdKey           = mkPreludeMiscIdUnique 390
-sigTDataConKey      = mkPreludeMiscIdUnique 391
-equalityTIdKey      = mkPreludeMiscIdUnique 392
-litTIdKey           = mkPreludeMiscIdUnique 393
-promotedTIdKey      = mkPreludeMiscIdUnique 394
-promotedTupleTIdKey = mkPreludeMiscIdUnique 395
-promotedNilTIdKey   = mkPreludeMiscIdUnique 396
-promotedConsTIdKey  = mkPreludeMiscIdUnique 397
-wildCardTIdKey      = mkPreludeMiscIdUnique 398
+    wildCardTIdKey, implicitParamTIdKey :: Unique
+forallTIdKey        = mkPreludeMiscIdUnique 391
+varTIdKey           = mkPreludeMiscIdUnique 392
+conTIdKey           = mkPreludeMiscIdUnique 393
+tupleTIdKey         = mkPreludeMiscIdUnique 394
+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396
+arrowTIdKey         = mkPreludeMiscIdUnique 397
+listTIdKey          = mkPreludeMiscIdUnique 398
+appTIdKey           = mkPreludeMiscIdUnique 399
+sigTIdKey           = mkPreludeMiscIdUnique 400
+equalityTIdKey      = mkPreludeMiscIdUnique 401
+litTIdKey           = mkPreludeMiscIdUnique 402
+promotedTIdKey      = mkPreludeMiscIdUnique 403
+promotedTupleTIdKey = mkPreludeMiscIdUnique 404
+promotedNilTIdKey   = mkPreludeMiscIdUnique 405
+promotedConsTIdKey  = mkPreludeMiscIdUnique 406
+wildCardTIdKey      = mkPreludeMiscIdUnique 407
+implicitParamTIdKey = mkPreludeMiscIdUnique 408
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 400
-strTyLitIdKey = mkPreludeMiscIdUnique 401
+numTyLitIdKey = mkPreludeMiscIdUnique 410
+strTyLitIdKey = mkPreludeMiscIdUnique 411
 
 -- data TyVarBndr = ...
 plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey       = mkPreludeMiscIdUnique 402
-kindedTVIdKey      = mkPreludeMiscIdUnique 403
+plainTVIdKey       = mkPreludeMiscIdUnique 412
+kindedTVIdKey      = mkPreludeMiscIdUnique 413
 
 -- data Role = ...
 nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey          = mkPreludeMiscIdUnique 404
-representationalRIdKey = mkPreludeMiscIdUnique 405
-phantomRIdKey          = mkPreludeMiscIdUnique 406
-inferRIdKey            = mkPreludeMiscIdUnique 407
+nominalRIdKey          = mkPreludeMiscIdUnique 414
+representationalRIdKey = mkPreludeMiscIdUnique 415
+phantomRIdKey          = mkPreludeMiscIdUnique 416
+inferRIdKey            = mkPreludeMiscIdUnique 417
 
 -- data Kind = ...
 varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
   starKIdKey, constraintKIdKey :: Unique
-varKIdKey         = mkPreludeMiscIdUnique 408
-conKIdKey         = mkPreludeMiscIdUnique 409
-tupleKIdKey       = mkPreludeMiscIdUnique 410
-arrowKIdKey       = mkPreludeMiscIdUnique 411
-listKIdKey        = mkPreludeMiscIdUnique 412
-appKIdKey         = mkPreludeMiscIdUnique 413
-starKIdKey        = mkPreludeMiscIdUnique 414
-constraintKIdKey  = mkPreludeMiscIdUnique 415
+varKIdKey         = mkPreludeMiscIdUnique 418
+conKIdKey         = mkPreludeMiscIdUnique 419
+tupleKIdKey       = mkPreludeMiscIdUnique 420
+arrowKIdKey       = mkPreludeMiscIdUnique 421
+listKIdKey        = mkPreludeMiscIdUnique 422
+appKIdKey         = mkPreludeMiscIdUnique 423
+starKIdKey        = mkPreludeMiscIdUnique 424
+constraintKIdKey  = mkPreludeMiscIdUnique 425
 
 -- data FamilyResultSig = ...
 noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
-noSigIdKey        = mkPreludeMiscIdUnique 416
-kindSigIdKey      = mkPreludeMiscIdUnique 417
-tyVarSigIdKey     = mkPreludeMiscIdUnique 418
+noSigIdKey        = mkPreludeMiscIdUnique 426
+kindSigIdKey      = mkPreludeMiscIdUnique 427
+tyVarSigIdKey     = mkPreludeMiscIdUnique 428
 
 -- data InjectivityAnn = ...
 injectivityAnnIdKey :: Unique
-injectivityAnnIdKey = mkPreludeMiscIdUnique 419
+injectivityAnnIdKey = mkPreludeMiscIdUnique 429
 
 -- data Callconv = ...
 cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
   javaScriptCallIdKey :: Unique
-cCallIdKey          = mkPreludeMiscIdUnique 420
-stdCallIdKey        = mkPreludeMiscIdUnique 421
-cApiCallIdKey       = mkPreludeMiscIdUnique 422
-primCallIdKey       = mkPreludeMiscIdUnique 423
-javaScriptCallIdKey = mkPreludeMiscIdUnique 424
+cCallIdKey          = mkPreludeMiscIdUnique 430
+stdCallIdKey        = mkPreludeMiscIdUnique 431
+cApiCallIdKey       = mkPreludeMiscIdUnique 432
+primCallIdKey       = mkPreludeMiscIdUnique 433
+javaScriptCallIdKey = mkPreludeMiscIdUnique 434
 
 -- data Safety = ...
 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey        = mkPreludeMiscIdUnique 430
-safeIdKey          = mkPreludeMiscIdUnique 431
-interruptibleIdKey = mkPreludeMiscIdUnique 432
+unsafeIdKey        = mkPreludeMiscIdUnique 440
+safeIdKey          = mkPreludeMiscIdUnique 441
+interruptibleIdKey = mkPreludeMiscIdUnique 442
 
 -- data FunDep = ...
 funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 440
-
--- data FamFlavour = ...
-typeFamIdKey, dataFamIdKey :: Unique
-typeFamIdKey = mkPreludeMiscIdUnique 450
-dataFamIdKey = mkPreludeMiscIdUnique 451
+funDepIdKey = mkPreludeMiscIdUnique 445
 
 -- data TySynEqn = ...
 tySynEqnIdKey :: Unique
@@ -1066,6 +1056,14 @@ moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
 derivClauseIdKey :: Unique
 derivClauseIdKey = mkPreludeMiscIdUnique 493
 
+-- data DerivStrategy = ...
+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,
+  viaStrategyIdKey :: Unique
+stockStrategyIdKey    = mkPreludeDataConUnique 494
+anyclassStrategyIdKey = mkPreludeDataConUnique 495
+newtypeStrategyIdKey  = mkPreludeDataConUnique 496
+viaStrategyIdKey      = mkPreludeDataConUnique 497
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 0732b5636d..c5af4a5121 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -30,7 +30,7 @@ module TysPrim(
         tYPE, primRepToRuntimeRep,
 
         funTyCon, funTyConName,
-        primTyCons,
+        unexposedPrimTyCons, exposedPrimTyCons, primTyCons,
 
         charPrimTyCon,          charPrimTy, charPrimTyConName,
         intPrimTyCon,           intPrimTy, intPrimTyConName,
@@ -80,6 +80,8 @@ module TysPrim(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} TysWiredIn
   ( runtimeRepTy, unboxedTupleKind, liftedTypeKind
   , vecRepDataConTyCon, tupleRepDataConTyCon
@@ -94,7 +96,7 @@ import {-# SOURCE #-} TysWiredIn
   , doubleElemRepDataConTy
   , mkPromotedListTy )
 
-import Var              ( TyVar, TyVarBndr(TvBndr), mkTyVar )
+import Var              ( TyVar, VarBndr(Bndr), mkTyVar )
 import Name
 import TyCon
 import SrcLoc
@@ -116,7 +118,22 @@ import Data.Char
 -}
 
 primTyCons :: [TyCon]
-primTyCons
+primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons
+
+-- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed.
+-- It's important to keep these separate as we don't want users to be able to
+-- write them (see Trac #15209) or see them in GHCi's @:browse@ output
+-- (see Trac #12023).
+unexposedPrimTyCons :: [TyCon]
+unexposedPrimTyCons
+  = [ eqPrimTyCon
+    , eqReprPrimTyCon
+    , eqPhantPrimTyCon
+    ]
+
+-- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim".
+exposedPrimTyCons :: [TyCon]
+exposedPrimTyCons
   = [ addrPrimTyCon
     , arrayPrimTyCon
     , byteArrayPrimTyCon
@@ -148,9 +165,6 @@ primTyCons
     , wordPrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
-    , eqPrimTyCon
-    , eqReprPrimTyCon
-    , eqPhantPrimTyCon
 
     , tYPETyCon
 
@@ -326,7 +340,7 @@ openBetaTy  = mkTyVarTy openBetaTyVar
 -}
 
 funTyConName :: Name
-funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
 
 -- | The @(->)@ type constructor.
 --
@@ -337,8 +351,8 @@ funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 funTyCon :: TyCon
 funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
   where
-    tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred)
-               , TvBndr runtimeRep2TyVar (NamedTCB Inferred)
+    tc_bndrs = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)
+               , Bndr runtimeRep2TyVar (NamedTCB Inferred)
                ]
                ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
                                              , tYPE runtimeRep2Ty
@@ -580,18 +594,19 @@ Note [The equality types story]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 GHC sports a veritable menagerie of equality types:
 
-              Hetero?   Levity      Result       Role      Defining module
-              ------------------------------------------------------------
-  ~#          hetero    unlifted    #            nominal   GHC.Prim
-  ~~          hetero    lifted      Constraint   nominal   GHC.Types
-  ~           homo      lifted      Constraint   nominal   Data.Type.Equality
-  :~:         homo      lifted      *            nominal   Data.Type.Equality
-
-  ~R#         hetero    unlifted    #            repr      GHC.Prim
-  Coercible   homo      lifted      Constraint   repr      GHC.Types
-  Coercion    homo      lifted      *            repr      Data.Type.Coercion
+         Type or  Lifted?  Hetero?  Role      Built in         Defining module
+         class?    L/U                        TyCon
+-----------------------------------------------------------------------------------------
+~#         T        U      hetero   nominal   eqPrimTyCon      GHC.Prim
+~~         C        L      hetero   nominal   heqTyCon         GHC.Types
+~          C        L      homo     nominal   eqTyCon          GHC.Types
+:~:        T        L      homo     nominal   (not built-in)   Data.Type.Equality
+:~~:       T        L      hetero   nominal   (not built-in)   Data.Type.Equality
 
-  ~P#         hetero    unlifted                 phantom   GHC.Prim
+~R#        T        U      hetero   repr      eqReprPrimTy     GHC.Prim
+Coercible  C        L      homo     repr      coercibleTyCon   GHC.Types
+Coercion   T        L      homo     repr      (not built-in)   Data.Type.Coercion
+~P#        T        U      hetero   phantom   eqPhantPrimTyCon GHC.Prim
 
 Recall that "hetero" means the equality can related types of different
 kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2)
@@ -627,6 +642,7 @@ This is (almost) an ordinary class, defined as if by
   class a ~# b => a ~~ b
   instance a ~# b => a ~~ b
 Here's what's unusual about it:
+
  * We can't actually declare it that way because we don't have syntax for ~#.
    And ~# isn't a constraint, so even if we could write it, it wouldn't kind
    check.
@@ -636,8 +652,8 @@ Here's what's unusual about it:
  * It is "naturally coherent". This means that the solver won't hesitate to
    solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the
    context. (Normally, it waits to learn more, just in case the given
-   influences what happens next.) This is quite like having
-   IncoherentInstances enabled.
+   influences what happens next.) See Note [Naturally coherent classes]
+   in TcInteract.
 
  * It always terminates. That is, in the UndecidableInstances checks, we
    don't worry if a (~~) constraint is too big, as we know that solving
@@ -656,28 +672,31 @@ Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn.
     --------------------------
     (~) :: forall k. k -> k -> Constraint
     --------------------------
-This is defined in Data.Type.Equality:
-  class a ~~ b => (a :: k) ~ (b :: k)
-  instance a ~~ b => a ~ b
-This is even more so an ordinary class than (~~), with the following exceptions:
- * Users cannot write instances of it.
+This is /exactly/ like (~~), except with a homogeneous kind.
+It is an almost-ordinary class defined as if by
+  class a ~# b => (a :: k) ~ (b :: k)
+  instance a ~# b => a ~ b
 
- * It is "naturally coherent". (See (~~).)
+ * All the bullets for (~~) apply
 
- * (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported
-   or imported.
+ * In addition (~) is magical syntax, as ~ is a reserved symbol.
+   It cannot be exported or imported.
 
- * It always terminates.
+Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn.
 
-Within GHC, ~ is called eqTyCon, and it is defined in PrelNames. Note that
-it is *not* wired in.
+Historical note: prior to July 18 (~) was defined as a
+  more-ordinary class with (~~) as a superclass.  But that made it
+  special in different ways; and the extra superclass selections to
+  get from (~) to (~#) via (~~) were tiresome.  Now it's defined
+  uniformly with (~~) and Coercible; much nicer.)
 
 
     --------------------------
     (:~:) :: forall k. k -> k -> *
+    (:~~:) :: forall k1 k2. k1 -> k2 -> *
     --------------------------
-This is a perfectly ordinary GADT, wrapping (~). It is not defined within
-GHC at all.
+These are perfectly ordinary GADTs, wrapping (~) and (~~) resp.
+They are not defined within GHC at all.
 
 
     --------------------------
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 28c6629a91..1d47185f02 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -29,9 +29,9 @@ module TysWiredIn (
 
         -- * Ordering
         orderingTyCon,
-        ltDataCon, ltDataConId,
-        eqDataCon, eqDataConId,
-        gtDataCon, gtDataConId,
+        ordLTDataCon, ordLTDataConId,
+        ordEQDataCon, ordEQDataConId,
+        ordGTDataCon, ordGTDataConId,
         promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,
 
         -- * Boxing primitive types
@@ -91,17 +91,12 @@ module TysWiredIn (
         -- * Kinds
         typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
         isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
-        starKindTyCon, starKindTyConName,
-        unicodeStarKindTyCon, unicodeStarKindTyConName,
         liftedTypeKindTyCon, constraintKindTyCon,
-
-        -- * Parallel arrays
-        mkPArrTy,
-        parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
-        parrTyCon_RDR, parrTyConName,
+        liftedTypeKindTyConName,
 
         -- * Equality predicates
-        heqTyCon, heqClass, heqDataCon,
+        heqTyCon, heqTyConName, heqClass, heqDataCon,
+        eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,
         coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,
 
         -- * RuntimeRep and friends
@@ -128,6 +123,8 @@ module TysWiredIn (
 #include "HsVersions.h"
 #include "MachDeps.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )
 
 -- friends:
@@ -148,7 +145,7 @@ import TyCon
 import Class            ( Class, mkClass )
 import RdrName
 import Name
-import NameEnv          ( NameEnv, mkNameEnv, lookupNameEnv )
+import NameEnv          ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )
 import NameSet          ( NameSet, mkNameSet, elemNameSet )
 import BasicTypes       ( Arity, Boxity(..), TupleSort(..), ConTagZ,
                           SourceText(..) )
@@ -162,10 +159,6 @@ import Util
 import BooleanFormula   ( mkAnd )
 
 import qualified Data.ByteString.Char8 as BS
-#if !MIN_VERSION_bytestring(0,10,8)
-import qualified Data.ByteString.Internal as BSI
-import qualified Data.ByteString.Unsafe as BSU
-#endif
 
 alpha_tyvar :: [TyVar]
 alpha_tyvar = [alphaTyVar]
@@ -222,8 +215,8 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
                 , word8TyCon
                 , listTyCon
                 , maybeTyCon
-                , parrTyCon
                 , heqTyCon
+                , eqTyCon
                 , coercibleTyCon
                 , typeNatKindCon
                 , typeSymbolKindCon
@@ -232,8 +225,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because then
                 , vecElemTyCon
                 , constraintKindTyCon
                 , liftedTypeKindTyCon
-                , starKindTyCon
-                , unicodeStarKindTyCon
                 ]
 
 mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name
@@ -254,16 +245,26 @@ mkWiredInIdName mod fs uniq id
 
 -- See Note [Kind-changing of (~) and Coercible]
 -- in libraries/ghc-prim/GHC/Types.hs
+eqTyConName, eqDataConName, eqSCSelIdName :: Name
+eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConKey   eqTyCon
+eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
+eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
+
+eqTyCon_RDR :: RdrName
+eqTyCon_RDR = nameRdrName eqTyConName
+
+-- See Note [Kind-changing of (~) and Coercible]
+-- in libraries/ghc-prim/GHC/Types.hs
 heqTyConName, heqDataConName, heqSCSelIdName :: Name
 heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon
-heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#")  heqDataConKey heqDataCon
-heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "HEq_sc") heqSCSelIdKey heqSCSelId
+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon
+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId
 
 -- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs
 coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name
 coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon
 coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon
-coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "Coercible_sc") coercibleSCSelIdKey coercibleSCSelId
+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId
 
 charTyConName, charDataConName, intTyConName, intDataConName :: Name
 charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon
@@ -282,11 +283,11 @@ nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") ni
 consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
 
 maybeTyConName, nothingDataConName, justDataConName :: Name
-maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_BASE (fsLit "Maybe")
+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")
                                           maybeTyConKey maybeTyCon
-nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing")
+nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
                                           nothingDataConKey nothingDataCon
-justDataConName    = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just")
+justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
                                           justDataConKey justDataCon
 
 wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
@@ -397,11 +398,8 @@ typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol")
 constraintKindTyConName :: Name
 constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon
 
-liftedTypeKindTyConName, starKindTyConName, unicodeStarKindTyConName
-  :: Name
+liftedTypeKindTyConName :: Name
 liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon
-starKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "*") starKindTyConKey starKindTyCon
-unicodeStarKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "★") unicodeStarKindTyConKey unicodeStarKindTyCon
 
 runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name
 runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon
@@ -447,14 +445,8 @@ vecElemDataConNames = zipWith3Lazy mk_special_dc_name
 mk_special_dc_name :: FastString -> Unique -> DataCon -> Name
 mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc
 
-parrTyConName, parrDataConName :: Name
-parrTyConName   = mkWiredInTyConName   BuiltInSyntax
-                    gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon
-parrDataConName = mkWiredInDataConName UserSyntax
-                    gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
-
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
-    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR :: RdrName
+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName
 boolTyCon_RDR   = nameRdrName boolTyConName
 false_RDR       = nameRdrName falseDataConName
 true_RDR        = nameRdrName trueDataConName
@@ -463,7 +455,6 @@ charTyCon_RDR   = nameRdrName charTyConName
 intDataCon_RDR  = nameRdrName intDataConName
 listTyCon_RDR   = nameRdrName listTyConName
 consDataCon_RDR = nameRdrName consDataConName
-parrTyCon_RDR   = nameRdrName parrTyConName
 
 {-
 ************************************************************************
@@ -473,31 +464,30 @@ parrTyCon_RDR   = nameRdrName parrTyConName
 ************************************************************************
 -}
 
-pcNonEnumTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
--- Not an enumeration
-pcNonEnumTyCon = pcTyCon False
-
 -- This function assumes that the types it creates have all parameters at
 -- Representational role, and that there is no kind polymorphism.
-pcTyCon :: Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
-pcTyCon is_enum name cType tyvars cons
+pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon
+pcTyCon name cType tyvars cons
   = mkAlgTyCon name
                 (mkAnonTyConBinders tyvars)
                 liftedTypeKind
                 (map (const Representational) tyvars)
                 cType
                 []              -- No stupid theta
-                (DataTyCon cons is_enum)
+                (mkDataTyConRhs cons)
                 (VanillaAlgTyCon (mkPrelTyConRepName name))
                 False           -- Not in GADT syntax
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
-pcDataCon n univs = pcDataConWithFixity False n univs []  -- no ex_tvs
+pcDataCon n univs = pcDataConWithFixity False n univs
+                      []    -- no ex_tvs
+                      univs -- the univs are precisely the user-written tyvars
 
 pcDataConWithFixity :: Bool      -- ^ declared infix?
                     -> Name      -- ^ datacon name
                     -> [TyVar]   -- ^ univ tyvars
-                    -> [TyVar]   -- ^ ex tyvars
+                    -> [TyCoVar] -- ^ ex tycovars
+                    -> [TyCoVar] -- ^ user-written tycovars
                     -> [Type]    -- ^ args
                     -> TyCon
                     -> DataCon
@@ -511,24 +501,33 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n
 -- one DataCon unique per pair of Ints.
 
 pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
-                     -> [TyVar] -> [TyVar]
+                     -> [TyVar] -> [TyCoVar] -> [TyCoVar]
                      -> [Type] -> TyCon -> DataCon
 -- The Name should be in the DataName name space; it's the name
 -- of the DataCon itself.
 
-pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key rri
+                     tyvars ex_tyvars user_tyvars arg_tys tycon
   = data_con
   where
+    tag_map = mkTyConTagMap tycon
+    -- This constructs the constructor Name to ConTag map once per
+    -- constructor, which is quadratic. It's OK here, because it's
+    -- only called for wired in data types that don't have a lot of
+    -- constructors. It's also likely that GHC will lift tag_map, since
+    -- we call pcDataConWithFixity' with static TyCons in the same module.
+    -- See Note [Constructor tag allocation] and #14657
     data_con = mkDataCon dc_name declared_infix prom_info
                 (map (const no_bang) arg_tys)
                 []      -- No labelled fields
-                (mkTyVarBinders Specified tyvars)
-                (mkTyVarBinders Specified ex_tyvars)
+                tyvars ex_tyvars
+                (mkTyCoVarBinders Specified user_tyvars)
                 []      -- No equality spec
                 []      -- No theta
                 arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
                 rri
                 tycon
+                (lookupNameEnv_NF tag_map dc_name)
                 []      -- No stupid theta
                 (mkDataConWorkId wrk_name data_con)
                 NoDataConRep    -- Wired-in types are too simple to need wrappers
@@ -554,7 +553,7 @@ mkDataConWorkerName data_con wrk_key =
 pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
 pcSpecialDataCon dc_name arg_tys tycon rri
   = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri
-                         [] [] arg_tys tycon
+                         [] [] [] arg_tys tycon
 
 {-
 ************************************************************************
@@ -567,16 +566,15 @@ pcSpecialDataCon dc_name arg_tys tycon rri
 typeNatKindCon, typeSymbolKindCon :: TyCon
 -- data Nat
 -- data Symbol
-typeNatKindCon    = pcTyCon False typeNatKindConName    Nothing [] []
-typeSymbolKindCon = pcTyCon False typeSymbolKindConName Nothing [] []
+typeNatKindCon    = pcTyCon typeNatKindConName    Nothing [] []
+typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []
 
 typeNatKind, typeSymbolKind :: Kind
 typeNatKind    = mkTyConTy typeNatKindCon
 typeSymbolKind = mkTyConTy typeSymbolKindCon
 
 constraintKindTyCon :: TyCon
-constraintKindTyCon = pcTyCon False constraintKindTyConName
-                              Nothing [] []
+constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
 
 liftedTypeKind, constraintKind :: Kind
 liftedTypeKind   = tYPE liftedRepTy
@@ -587,7 +585,7 @@ constraintKind   = mkTyConApp constraintKindTyCon []
 mkFunKind :: Kind -> Kind -> Kind
 mkFunKind = mkFunTy
 
-mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind
+mkForAllKind :: TyCoVar -> ArgFlag -> Kind -> Kind
 mkForAllKind = mkForAllTy
 
 {-
@@ -623,12 +621,13 @@ Note [How tuples work]  See also Note [Known-key names] in PrelNames
     - Given constraints: the superclasses automatically become available
     - Wanted constraints: there is a built-in instance
          instance (c1,c2) => (c1,c2)
-    - Currently just go up to 16; beyond that
+      See TcInteract.matchCTuple
+    - Currently just go up to 62; beyond that
       you have to use manual nesting
     - Their OccNames look like (%,,,%), so they can easily be
       distinguished from term tuples.  But (following Haskell) we
-      pretty-print saturated constraint tuples with round parens; see
-      BasicTypes.tupleParens.
+      pretty-print saturated constraint tuples with round parens;
+      see BasicTypes.tupleParens.
 
 * In quite a lot of places things are restrcted just to
   BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish
@@ -686,11 +685,12 @@ isBuiltInOcc_maybe occ =
       "[]" -> Just $ choose_ns listTyConName nilDataConName
       ":"    -> Just consDataConName
 
-      "[::]" -> Just parrTyConName
+      -- equality tycon
+      "~"    -> Just eqTyConName
 
       -- boxed tuple data/tycon
       "()"    -> Just $ tup_name Boxed 0
-      _ | Just rest <- "(" `stripPrefix` name
+      _ | Just rest <- "(" `BS.stripPrefix` name
         , (commas, rest') <- BS.span (==',') rest
         , ")" <- rest'
              -> Just $ tup_name Boxed (1+BS.length commas)
@@ -698,21 +698,21 @@ isBuiltInOcc_maybe occ =
       -- unboxed tuple data/tycon
       "(##)"  -> Just $ tup_name Unboxed 0
       "Unit#" -> Just $ tup_name Unboxed 1
-      _ | Just rest <- "(#" `stripPrefix` name
+      _ | Just rest <- "(#" `BS.stripPrefix` name
         , (commas, rest') <- BS.span (==',') rest
         , "#)" <- rest'
              -> Just $ tup_name Unboxed (1+BS.length commas)
 
       -- unboxed sum tycon
-      _ | Just rest <- "(#" `stripPrefix` name
+      _ | Just rest <- "(#" `BS.stripPrefix` name
         , (pipes, rest') <- BS.span (=='|') rest
         , "#)" <- rest'
              -> Just $ tyConName $ sumTyCon (1+BS.length pipes)
 
       -- unboxed sum datacon
-      _ | Just rest <- "(#" `stripPrefix` name
+      _ | Just rest <- "(#" `BS.stripPrefix` name
         , (pipes1, rest') <- BS.span (=='|') rest
-        , Just rest'' <- "_" `stripPrefix` rest'
+        , Just rest'' <- "_" `BS.stripPrefix` rest'
         , (pipes2, rest''') <- BS.span (=='|') rest''
         , "#)" <- rest'''
              -> let arity = BS.length pipes1 + BS.length pipes2 + 1
@@ -720,15 +720,6 @@ isBuiltInOcc_maybe occ =
                 in Just $ dataConName $ sumDataCon alt arity
       _ -> Nothing
   where
-    -- TODO: Drop when bytestring 0.10.8 can be assumed
-#if MIN_VERSION_bytestring(0,10,8)
-    stripPrefix = BS.stripPrefix
-#else
-    stripPrefix bs1@(BSI.PS _ _ l1) bs2
-      | bs1 `BS.isPrefixOf` bs2 = Just (BSU.unsafeDrop l1 bs2)
-      | otherwise = Nothing
-#endif
-
     name = fastStringToByteString $ occNameFS occ
 
     choose_ns :: Name -> Name -> Name
@@ -1015,16 +1006,34 @@ mk_sum arity = (tycon, sum_cons)
 ********************************************************************* -}
 
 -- See Note [The equality types story] in TysPrim
--- (:~~: :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
+-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)
 --
 -- It's tempting to put functional dependencies on (~~), but it's not
 -- necessary because the functional-dependency coverage check looks
 -- through superclasses, and (~#) is handled in that check.
 
-heqTyCon, coercibleTyCon :: TyCon
-heqClass, coercibleClass :: Class
-heqDataCon, coercibleDataCon :: DataCon
-heqSCSelId, coercibleSCSelId :: Id
+eqTyCon,   heqTyCon,   coercibleTyCon   :: TyCon
+eqClass,   heqClass,   coercibleClass   :: Class
+eqDataCon, heqDataCon, coercibleDataCon :: DataCon
+eqSCSelId, heqSCSelId, coercibleSCSelId :: Id
+
+(eqTyCon, eqClass, eqDataCon, eqSCSelId)
+  = (tycon, klass, datacon, sc_sel_id)
+  where
+    tycon     = mkClassTyCon eqTyConName binders roles
+                             rhs klass
+                             (mkPrelTyConRepName eqTyConName)
+    klass     = mk_class tycon sc_pred sc_sel_id
+    datacon   = pcDataCon eqDataConName tvs [sc_pred] tycon
+
+    -- Kind: forall k. k -> k -> Constraint
+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
+    roles     = [Nominal, Nominal, Nominal]
+    rhs       = mkDataTyConRhs [datacon]
+
+    tvs@[k,a,b] = binderVars binders
+    sc_pred     = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])
+    sc_sel_id   = mkDictSelId eqSCSelIdName klass
 
 (heqTyCon, heqClass, heqDataCon, heqSCSelId)
   = (tycon, klass, datacon, sc_sel_id)
@@ -1038,7 +1047,7 @@ heqSCSelId, coercibleSCSelId :: Id
     -- Kind: forall k1 k2. k1 -> k2 -> Constraint
     binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks)
     roles     = [Nominal, Nominal, Nominal, Nominal]
-    rhs       = DataTyCon { data_cons = [datacon], is_enum = False }
+    rhs       = mkDataTyConRhs [datacon]
 
     tvs       = binderVars binders
     sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)
@@ -1056,7 +1065,7 @@ heqSCSelId, coercibleSCSelId :: Id
     -- Kind: forall k. k -> k -> Constraint
     binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])
     roles     = [Nominal, Representational, Representational]
-    rhs       = DataTyCon { data_cons = [datacon], is_enum = False }
+    rhs       = mkDataTyConRhs [datacon]
 
     tvs@[k,a,b] = binderVars binders
     sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])
@@ -1067,6 +1076,8 @@ mk_class tycon sc_pred sc_sel_id
   = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]
             [] [] (mkAnd []) tycon
 
+
+
 {- *********************************************************************
 *                                                                      *
                 Kinds and RuntimeRep
@@ -1078,27 +1089,15 @@ mk_class tycon sc_pred sc_sel_id
 runtimeRepTy :: Type
 runtimeRepTy = mkTyConTy runtimeRepTyCon
 
-liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon
-
 -- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim
 -- type Type = tYPE 'LiftedRep
--- type *    = tYPE 'LiftedRep
--- type *    = tYPE 'LiftedRep  -- Unicode variant
-
+liftedTypeKindTyCon :: TyCon
 liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName
                                        [] liftedTypeKind []
                                        (tYPE liftedRepTy)
 
-starKindTyCon         = buildSynTyCon starKindTyConName
-                                       [] liftedTypeKind []
-                                       (tYPE liftedRepTy)
-
-unicodeStarKindTyCon  = buildSynTyCon unicodeStarKindTyConName
-                                       [] liftedTypeKind []
-                                       (tYPE liftedRepTy)
-
 runtimeRepTyCon :: TyCon
-runtimeRepTyCon = pcNonEnumTyCon runtimeRepTyConName Nothing []
+runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
                           (vecRepDataCon : tupleRepDataCon :
                            sumRepDataCon : runtimeRepSimpleDataCons)
 
@@ -1171,8 +1170,7 @@ liftedRepDataConTy, unliftedRepDataConTy,
   = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
 
 vecCountTyCon :: TyCon
-vecCountTyCon = pcTyCon True vecCountTyConName Nothing []
-                        vecCountDataCons
+vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons
 
 -- See Note [Wiring in RuntimeRep]
 vecCountDataCons :: [DataCon]
@@ -1190,7 +1188,7 @@ vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
   vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons
 
 vecElemTyCon :: TyCon
-vecElemTyCon = pcTyCon True vecElemTyConName Nothing [] vecElemDataCons
+vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons
 
 -- See Note [Wiring in RuntimeRep]
 vecElemDataCons :: [DataCon]
@@ -1255,7 +1253,7 @@ charTy :: Type
 charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
-charTyCon   = pcNonEnumTyCon charTyConName
+charTyCon   = pcTyCon charTyConName
                    (Just (CType NoSourceText Nothing
                                   (NoSourceText,fsLit "HsChar")))
                    [] [charDataCon]
@@ -1269,7 +1267,7 @@ intTy :: Type
 intTy = mkTyConTy intTyCon
 
 intTyCon :: TyCon
-intTyCon = pcNonEnumTyCon intTyConName
+intTyCon = pcTyCon intTyConName
                (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))
                  [] [intDataCon]
 intDataCon :: DataCon
@@ -1279,7 +1277,7 @@ wordTy :: Type
 wordTy = mkTyConTy wordTyCon
 
 wordTyCon :: TyCon
-wordTyCon = pcNonEnumTyCon wordTyConName
+wordTyCon = pcTyCon wordTyConName
             (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))
                [] [wordDataCon]
 wordDataCon :: DataCon
@@ -1289,10 +1287,10 @@ word8Ty :: Type
 word8Ty = mkTyConTy word8TyCon
 
 word8TyCon :: TyCon
-word8TyCon = pcNonEnumTyCon word8TyConName
-                      (Just (CType NoSourceText Nothing
-                             (NoSourceText, fsLit "HsWord8"))) []
-                      [word8DataCon]
+word8TyCon = pcTyCon word8TyConName
+                     (Just (CType NoSourceText Nothing
+                            (NoSourceText, fsLit "HsWord8"))) []
+                     [word8DataCon]
 word8DataCon :: DataCon
 word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
 
@@ -1300,7 +1298,7 @@ floatTy :: Type
 floatTy = mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
-floatTyCon   = pcNonEnumTyCon floatTyConName
+floatTyCon   = pcTyCon floatTyConName
                       (Just (CType NoSourceText Nothing
                              (NoSourceText, fsLit "HsFloat"))) []
                       [floatDataCon]
@@ -1311,7 +1309,7 @@ doubleTy :: Type
 doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
-doubleTyCon = pcNonEnumTyCon doubleTyConName
+doubleTyCon = pcTyCon doubleTyConName
                       (Just (CType NoSourceText Nothing
                              (NoSourceText,fsLit "HsDouble"))) []
                       [doubleDataCon]
@@ -1373,7 +1371,7 @@ boolTy :: Type
 boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
-boolTyCon = pcTyCon True boolTyConName
+boolTyCon = pcTyCon boolTyConName
                     (Just (CType NoSourceText Nothing
                            (NoSourceText, fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
@@ -1387,18 +1385,18 @@ falseDataConId = dataConWorkId falseDataCon
 trueDataConId  = dataConWorkId trueDataCon
 
 orderingTyCon :: TyCon
-orderingTyCon = pcTyCon True orderingTyConName Nothing
-                        [] [ltDataCon, eqDataCon, gtDataCon]
+orderingTyCon = pcTyCon orderingTyConName Nothing
+                        [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]
 
-ltDataCon, eqDataCon, gtDataCon :: DataCon
-ltDataCon = pcDataCon ltDataConName  [] [] orderingTyCon
-eqDataCon = pcDataCon eqDataConName  [] [] orderingTyCon
-gtDataCon = pcDataCon gtDataConName  [] [] orderingTyCon
+ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon
+ordLTDataCon = pcDataCon ordLTDataConName  [] [] orderingTyCon
+ordEQDataCon = pcDataCon ordEQDataConName  [] [] orderingTyCon
+ordGTDataCon = pcDataCon ordGTDataConName  [] [] orderingTyCon
 
-ltDataConId, eqDataConId, gtDataConId :: Id
-ltDataConId = dataConWorkId ltDataCon
-eqDataConId = dataConWorkId eqDataCon
-gtDataConId = dataConWorkId gtDataCon
+ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id
+ordLTDataConId = dataConWorkId ordLTDataCon
+ordEQDataConId = dataConWorkId ordEQDataCon
+ordGTDataConId = dataConWorkId ordGTDataCon
 
 {-
 ************************************************************************
@@ -1416,11 +1414,12 @@ mkListTy :: Type -> Type
 mkListTy ty = mkTyConApp listTyCon [ty]
 
 listTyCon :: TyCon
-listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational]
-                          Nothing []
-                          (DataTyCon [nilDataCon, consDataCon] False )
-                          False
-                          (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
+listTyCon =
+  buildAlgTyCon listTyConName alpha_tyvar [Representational]
+                Nothing []
+                (mkDataTyConRhs [nilDataCon, consDataCon])
+                False
+                (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName)
 
 nilDataCon :: DataCon
 nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon
@@ -1428,7 +1427,8 @@ nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon
 consDataCon :: DataCon
 consDataCon = pcDataConWithFixity True {- Declared infix -}
                consDataConName
-               alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
+               alpha_tyvar [] alpha_tyvar
+               [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
 -- Interesting: polymorphic recursion would help here.
 -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
 -- gets the over-specific type (Type -> Type)
@@ -1436,7 +1436,7 @@ consDataCon = pcDataConWithFixity True {- Declared infix -}
 -- Wired-in type Maybe
 
 maybeTyCon :: TyCon
-maybeTyCon = pcTyCon False maybeTyConName Nothing alpha_tyvar
+maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar
                      [nothingDataCon, justDataCon]
 
 nothingDataCon :: DataCon
@@ -1500,7 +1500,7 @@ mkTupleTy :: Boxity -> [Type] -> Type
 mkTupleTy Boxed   [ty] = ty
 mkTupleTy Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys
 mkTupleTy Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))
-                                        (map (getRuntimeRep "mkTupleTy") tys ++ tys)
+                                        (map getRuntimeRep tys ++ tys)
 
 -- | Build the type of a small tuple that holds the specified type of thing
 mkBoxedTupleTy :: [Type] -> Type
@@ -1518,79 +1518,7 @@ unitTy = mkTupleTy Boxed []
 
 mkSumTy :: [Type] -> Type
 mkSumTy tys = mkTyConApp (sumTyCon (length tys))
-                         (map (getRuntimeRep "mkSumTy") tys ++ tys)
-
-{- *********************************************************************
-*                                                                      *
-        The parallel-array type,  [::]
-*                                                                      *
-************************************************************************
-
-Special syntax for parallel arrays needs some wired in definitions.
--}
-
--- | Construct a type representing the application of the parallel array constructor
-mkPArrTy    :: Type -> Type
-mkPArrTy ty  = mkTyConApp parrTyCon [ty]
-
--- | Represents the type constructor of parallel arrays
---
---  * This must match the definition in @PrelPArr@
---
--- NB: Although the constructor is given here, it will not be accessible in
---     user code as it is not in the environment of any compiled module except
---     @PrelPArr@.
---
-parrTyCon :: TyCon
-parrTyCon  = pcNonEnumTyCon parrTyConName Nothing alpha_tyvar [parrDataCon]
-
-parrDataCon :: DataCon
-parrDataCon  = pcDataCon
-                 parrDataConName
-                 alpha_tyvar            -- forall'ed type variables
-                 [intTy,                -- 1st argument: Int
-                  mkTyConApp            -- 2nd argument: Array# a
-                    arrayPrimTyCon
-                    alpha_ty]
-                 parrTyCon
-
--- | Check whether a type constructor is the constructor for parallel arrays
-isPArrTyCon    :: TyCon -> Bool
-isPArrTyCon tc  = tyConName tc == parrTyConName
-
--- | Fake array constructors
---
--- * These constructors are never really used to represent array values;
---   however, they are very convenient during desugaring (and, in particular,
---   in the pattern matching compiler) to treat array pattern just like
---   yet another constructor pattern
---
-parrFakeCon                        :: Arity -> DataCon
-parrFakeCon i | i > mAX_TUPLE_SIZE  = mkPArrFakeCon  i  -- build one specially
-parrFakeCon i                       = parrFakeConArr!i
-
--- pre-defined set of constructors
---
-parrFakeConArr :: Array Int DataCon
-parrFakeConArr  = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)
-                                            | i <- [0..mAX_TUPLE_SIZE]]
-
--- build a fake parallel array constructor for the given arity
---
-mkPArrFakeCon       :: Int -> DataCon
-mkPArrFakeCon arity  = data_con
-  where
-        data_con  = pcDataCon name [tyvar] tyvarTys parrTyCon
-        tyvar     = head alphaTyVars
-        tyvarTys  = replicate arity $ mkTyVarTy tyvar
-        nameStr   = mkFastString ("MkPArr" ++ show arity)
-        name      = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
-                                  (AConLike (RealDataCon data_con)) UserSyntax
-        unique      = mkPArrDataConUnique arity
-
--- | Checks whether a data constructor is a fake constructor for parallel arrays
-isPArrFakeCon      :: DataCon -> Bool
-isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)
+                         (map getRuntimeRep tys ++ tys)
 
 -- Promoted Booleans
 
@@ -1609,9 +1537,9 @@ promotedLTDataCon
   , promotedEQDataCon
   , promotedGTDataCon
   :: TyCon
-promotedLTDataCon     = promoteDataCon ltDataCon
-promotedEQDataCon     = promoteDataCon eqDataCon
-promotedGTDataCon     = promoteDataCon gtDataCon
+promotedLTDataCon     = promoteDataCon ordLTDataCon
+promotedEQDataCon     = promoteDataCon ordEQDataCon
+promotedGTDataCon     = promoteDataCon ordGTDataCon
 
 -- Promoted List
 promotedConsDataCon, promotedNilDataCon :: TyCon
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index 26e42010c9..b777fa187b 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -12,6 +12,8 @@ listTyCon :: TyCon
 typeNatKind, typeSymbolKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
 
+coercibleTyCon, heqTyCon :: TyCon
+
 liftedTypeKind :: Kind
 constraintKind :: Kind
 
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 97ae89cb84..2f8ced7de8 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -38,6 +38,14 @@
 -- processors of this file to easily get hold of simple info
 -- (eg, out_of_line), whilst avoiding parsing complex expressions
 -- needed for strictness info.
+--
+-- type refers to the general category of the primop. Valid settings include,
+--
+--  * Compare:   A comparison operation of the shape a -> a -> Int#
+--  * Monadic:   A unary operation of shape a -> a
+--  * Dyadic:    A binary operation of shape a -> a -> a
+--  * GenPrimOp: Any other sort of primop
+--
 
 -- The vector attribute is rather special. It takes a list of 3-tuples, each of
 -- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of
@@ -83,10 +91,11 @@ section "The word size story."
          This is normally set based on the {\tt config.h} parameter
          {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64
          bits on 64-bit machines.  However, it can also be explicitly
-         set to a smaller number, e.g., 31 bits, to allow the
+         set to a smaller number than 64, e.g., 62 bits, to allow the
          possibility of using tag bits. Currently GHC itself has only
-         32-bit and 64-bit variants, but 30 or 31-bit code can be
+         32-bit and 64-bit variants, but 61, 62, or 63-bit code can be
          exported as an external core file for use in other back ends.
+         30 and 31-bit code is no longer supported.
 
          GHC also implements a primitive unsigned integer type {\tt
          Word\#} which always has the same number of bits as {\tt
@@ -97,7 +106,7 @@ section "The word size story."
          arithmetic operations, comparisons, and a range of
          conversions.  The 8-bit and 16-bit sizes are always
          represented as {\tt Int\#} and {\tt Word\#}, and the
-         operations implemented in terms of the the primops on these
+         operations implemented in terms of the primops on these
          types, with suitable range restrictions on the results (using
          the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families
          of primops.  The 32-bit sizes are represented using {\tt
@@ -134,13 +143,8 @@ section "The word size story."
 
 -- Define synonyms for indexing ops.
 
-#if WORD_SIZE_IN_BITS < 32
-#define INT32 Int32#
-#define WORD32 Word32#
-#else
 #define INT32 Int#
 #define WORD32 Word#
-#endif
 
 #if WORD_SIZE_IN_BITS < 64
 #define INT64 Int64#
@@ -176,7 +180,7 @@ primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#
 
 ------------------------------------------------------------------------
 section "Int#"
-        {Operations on native-size integers (30+ bits).}
+        {Operations on native-size integers (32+ bits).}
 ------------------------------------------------------------------------
 
 primtype Int#
@@ -257,6 +261,7 @@ primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
           nonzero if overflow occurred (the sum is either too large
           or too small to fit in an {\tt Int#}).}
    with code_size = 2
+        commutable = True
 
 primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)
          {Subtract signed integers reporting overflow.
@@ -312,7 +317,7 @@ primop   ISrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#
 
 ------------------------------------------------------------------------
 section "Word#"
-        {Operations on native-sized unsigned words (30+ bits).}
+        {Operations on native-sized unsigned words (32+ bits).}
 ------------------------------------------------------------------------
 
 primtype Word#
@@ -320,15 +325,25 @@ primtype Word#
 primop   WordAddOp   "plusWord#"   Dyadic   Word# -> Word# -> Word#
    with commutable = True
 
+primop   WordAddCOp   "addWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)
+         {Add unsigned integers reporting overflow.
+          The first element of the pair is the result.  The second element is
+          the carry flag, which is nonzero on overflow. See also {\tt plusWord2#}.}
+   with code_size = 2
+        commutable = True
+
 primop   WordSubCOp   "subWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)
          {Subtract unsigned integers reporting overflow.
           The first element of the pair is the result.  The second element is
           the carry flag, which is nonzero on overflow.}
+   with code_size = 2
 
--- Returns (# high, low #) (or equivalently, (# carry, low #))
-primop   WordAdd2Op  "plusWord2#"  GenPrimOp
-   Word# -> Word# -> (# Word#, Word# #)
-   with commutable = True
+primop   WordAdd2Op   "plusWord2#"   GenPrimOp   Word# -> Word# -> (# Word#, Word# #)
+         {Add unsigned integers, with the high part (carry) in the first
+          component of the returned pair and the low part in the second
+          component of the pair. See also {\tt addWordC#}.}
+   with code_size = 2
+        commutable = True
 
 primop   WordSubOp   "minusWord#"   Dyadic   Word# -> Word# -> Word#
 
@@ -395,6 +410,28 @@ primop   PopCnt64Op   "popCnt64#"   GenPrimOp   WORD64 -> Word#
 primop   PopCntOp   "popCnt#"   Monadic   Word# -> Word#
     {Count the number of set bits in a word.}
 
+primop   Pdep8Op   "pdep8#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 8 bits of a word at locations specified by a mask.}
+primop   Pdep16Op   "pdep16#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 16 bits of a word at locations specified by a mask.}
+primop   Pdep32Op   "pdep32#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to lower 32 bits of a word at locations specified by a mask.}
+primop   Pdep64Op   "pdep64#"   GenPrimOp   WORD64 -> WORD64 -> WORD64
+    {Deposit bits to a word at locations specified by a mask.}
+primop   PdepOp   "pdep#"   Dyadic   Word# -> Word# -> Word#
+    {Deposit bits to a word at locations specified by a mask.}
+
+primop   Pext8Op   "pext8#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 8 bits of a word at locations specified by a mask.}
+primop   Pext16Op   "pext16#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 16 bits of a word at locations specified by a mask.}
+primop   Pext32Op   "pext32#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from lower 32 bits of a word at locations specified by a mask.}
+primop   Pext64Op   "pext64#"   GenPrimOp   WORD64 -> WORD64 -> WORD64
+    {Extract bits from a word at locations specified by a mask.}
+primop   PextOp   "pext#"   Dyadic   Word# -> Word# -> Word#
+    {Extract bits from a word at locations specified by a mask.}
+
 primop   Clz8Op   "clz8#" Monadic   Word# -> Word#
     {Count leading zeros in the lower 8 bits of a word.}
 primop   Clz16Op   "clz16#" Monadic   Word# -> Word#
@@ -439,28 +476,6 @@ primop   Narrow16WordOp    "narrow16Word#"    Monadic   Word# -> Word#
 primop   Narrow32WordOp    "narrow32Word#"    Monadic   Word# -> Word#
 
 
-#if WORD_SIZE_IN_BITS < 32
-------------------------------------------------------------------------
-section "Int32#"
-        {Operations on 32-bit integers ({\tt Int32\#}).  This type is only used
-         if plain {\tt Int\#} has less than 32 bits.  In any case, the operations
-         are not primops; they are implemented (if needed) as ccalls instead.}
-------------------------------------------------------------------------
-
-primtype Int32#
-
-------------------------------------------------------------------------
-section "Word32#"
-        {Operations on 32-bit unsigned words. This type is only used
-         if plain {\tt Word\#} has less than 32 bits. In any case, the operations
-         are not primops; they are implemented (if needed) as ccalls instead.}
-------------------------------------------------------------------------
-
-primtype Word32#
-
-#endif
-
-
 #if WORD_SIZE_IN_BITS < 64
 ------------------------------------------------------------------------
 section "Int64#"
@@ -603,6 +618,21 @@ primop   DoubleTanhOp   "tanhDouble#"      Monadic
    with
    code_size = { primOpCodeSizeForeignCall }
 
+primop   DoubleAsinhOp   "asinhDouble#"      Monadic
+   Double# -> Double#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
+primop   DoubleAcoshOp   "acoshDouble#"      Monadic
+   Double# -> Double#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
+primop   DoubleAtanhOp   "atanhDouble#"      Monadic
+   Double# -> Double#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
 primop   DoublePowerOp   "**##" Dyadic
    Double# -> Double# -> Double#
    {Exponentiation.}
@@ -729,6 +759,21 @@ primop   FloatTanhOp   "tanhFloat#"      Monadic
    with
    code_size = { primOpCodeSizeForeignCall }
 
+primop   FloatAsinhOp   "asinhFloat#"      Monadic
+   Float# -> Float#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
+primop   FloatAcoshOp   "acoshFloat#"      Monadic
+   Float# -> Float#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
+primop   FloatAtanhOp   "atanhFloat#"      Monadic
+   Float# -> Float#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
 primop   FloatPowerOp   "powerFloat#"      Dyadic
    Float# -> Float# -> Float#
    with
@@ -788,8 +833,13 @@ primop  SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp
 
 primop  IndexArrayOp "indexArray#" GenPrimOp
    Array# a -> Int# -> (# a #)
-   {Read from specified index of immutable array. Result is packaged into
-    an unboxed singleton; the result itself is not yet evaluated.}
+   {Read from the specified index of an immutable array. The result is packaged
+    into an unboxed unary tuple; the result itself is not yet
+    evaluated. Pattern matching on the tuple forces the indexing of the
+    array to happen but does not evaluate the element itself. Evaluating
+    the thunk prevents additional thunks from building up on the
+    heap. Avoiding these thunks, in turn, reduces references to the
+    argument array, allowing it to be garbage collected more promptly.}
    with
    can_fail         = True
 
@@ -1224,6 +1274,76 @@ primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp
    {Read 64-bit word; offset in 64-bit words.}
    with can_fail = True
 
+primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read 8-bit character; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp
+   ByteArray# -> Int# -> Char#
+   {Read 31-bit character; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp
+   ByteArray# -> Int# -> Addr#
+   {Read address; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp
+   ByteArray# -> Int# -> Float#
+   {Read float; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp
+   ByteArray# -> Int# -> Double#
+   {Read double; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp
+   ByteArray# -> Int# -> StablePtr# a
+   {Read stable pointer; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read 16-bit int; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp
+   ByteArray# -> Int# -> INT32
+   {Read 32-bit int; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp
+   ByteArray# -> Int# -> INT64
+   {Read 64-bit int; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp
+   ByteArray# -> Int# -> Int#
+   {Read int; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read 16-bit word; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp
+   ByteArray# -> Int# -> WORD32
+   {Read 32-bit word; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp
+   ByteArray# -> Int# -> WORD64
+   {Read 64-bit word; offset in bytes.}
+   with can_fail = True
+
+primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp
+   ByteArray# -> Int# -> Word#
+   {Read word; offset in bytes.}
+   with can_fail = True
+
 primop  ReadByteArrayOp_Char "readCharArray#" GenPrimOp
    MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
    {Read 8-bit character; offset in bytes.}
@@ -1238,7 +1358,7 @@ primop  ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp
 
 primop  ReadByteArrayOp_Int "readIntArray#" GenPrimOp
    MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
-   {Read intger; offset in words.}
+   {Read integer; offset in words.}
    with has_side_effects = True
         can_fail = True
 
@@ -1308,6 +1428,76 @@ primop  ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp
    with has_side_effects = True
         can_fail = True
 
+primop  ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT32 #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, INT64 #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD32 #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, WORD64 #)
+   with has_side_effects = True
+        can_fail = True
+
+primop  ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)
+   with has_side_effects = True
+        can_fail = True
+
 primop  WriteByteArrayOp_Char "writeCharArray#" GenPrimOp
    MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
    {Write 8-bit character; offset in bytes.}
@@ -1390,11 +1580,99 @@ primop  WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp
    with has_side_effects = True
         can_fail = True
 
+primop  WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp
+   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp
+   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp
+   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp
+   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp
+   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT32 -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp
+   MutableByteArray# s -> Int# -> INT64 -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD32 -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp
+   MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp
+   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+
+primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp
+   ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
+   {{\tt compareByteArrays# src1 src1_ofs src2 src2_ofs n} compares
+    {\tt n} bytes starting at offset {\tt src1_ofs} in the first
+    {\tt ByteArray#} {\tt src1} to the range of {\tt n} bytes
+    (i.e. same length) starting at offset {\tt src2_ofs} of the second
+    {\tt ByteArray#} {\tt src2}.  Both arrays must fully contain the
+    specified ranges, but this is not checked.  Returns an {\tt Int#}
+    less than, equal to, or greater than zero if the range is found,
+    respectively, to be byte-wise lexicographically less than, to
+    match, or be greater than the second range.}
+   with
+   can_fail = True
+
 primop  CopyByteArrayOp "copyByteArray#" GenPrimOp
   ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-  {Copy a range of the ByteArray# to the specified region in the MutableByteArray#.
-   Both arrays must fully contain the specified ranges, but this is not checked.
-   The two arrays must not be the same array in different states, but this is not checked either.}
+  {{\tt copyByteArray# src src_ofs dst dst_ofs n} copies the range
+   starting at offset {\tt src_ofs} of length {\tt n} from the
+   {\tt ByteArray#} {\tt src} to the {\tt MutableByteArray#} {\tt dst}
+   starting at offset {\tt dst_ofs}.  Both arrays must fully contain
+   the specified ranges, but this is not checked.  The two arrays must
+   not be the same array in different states, but this is not checked
+   either.}
   with
   has_side_effects = True
   code_size = { primOpCodeSizeForeignCall + 4}
@@ -1402,7 +1680,7 @@ primop  CopyByteArrayOp "copyByteArray#" GenPrimOp
 
 primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp
   MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-  {Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#.
+  {Copy a range of the first MutableByteArray\# to the specified region in the second MutableByteArray\#.
    Both arrays must fully contain the specified ranges, but this is not checked. The regions are
    allowed to overlap, although this is only possible when the same array is provided
    as both the source and the destination.}
@@ -1413,10 +1691,10 @@ primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp
 
 primop  CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp
   ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s
-  {Copy a range of the ByteArray# to the memory range starting at the Addr#.
-   The ByteArray# and the memory region at Addr# must fully contain the
-   specified ranges, but this is not checked. The Addr# must not point into the
-   ByteArray# (e.g. if the ByteArray# were pinned), but this is not checked
+  {Copy a range of the ByteArray\# to the memory range starting at the Addr\#.
+   The ByteArray\# and the memory region at Addr\# must fully contain the
+   specified ranges, but this is not checked. The Addr\# must not point into the
+   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked
    either.}
   with
   has_side_effects = True
@@ -1425,10 +1703,10 @@ primop  CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp
 
 primop  CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp
   MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s
-  {Copy a range of the MutableByteArray# to the memory range starting at the
-   Addr#. The MutableByteArray# and the memory region at Addr# must fully
-   contain the specified ranges, but this is not checked. The Addr# must not
-   point into the MutableByteArray# (e.g. if the MutableByteArray# were
+  {Copy a range of the MutableByteArray\# to the memory range starting at the
+   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully
+   contain the specified ranges, but this is not checked. The Addr\# must not
+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were
    pinned), but this is not checked either.}
   with
   has_side_effects = True
@@ -1437,10 +1715,10 @@ primop  CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp
 
 primop  CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp
   Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
-  {Copy a memory range starting at the Addr# to the specified range in the
-   MutableByteArray#. The memory region at Addr# and the ByteArray# must fully
-   contain the specified ranges, but this is not checked. The Addr# must not
-   point into the MutableByteArray# (e.g. if the MutableByteArray# were pinned),
+  {Copy a memory range starting at the Addr\# to the specified range in the
+   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully
+   contain the specified ranges, but this is not checked. The Addr\# must not
+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),
    but this is not checked either.}
   with
   has_side_effects = True
@@ -1620,7 +1898,7 @@ primop  WriteArrayArrayOp_MutableArrayArray "writeMutableArrayArrayArray#" GenPr
 
 primop  CopyArrayArrayOp "copyArrayArray#" GenPrimOp
   ArrayArray# -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s
-  {Copy a range of the ArrayArray# to the specified region in the MutableArrayArray#.
+  {Copy a range of the ArrayArray\# to the specified region in the MutableArrayArray\#.
    Both arrays must fully contain the specified ranges, but this is not checked.
    The two arrays must not be the same array in different states, but this is not checked either.}
   with
@@ -1950,25 +2228,37 @@ primop  WriteMutVarOp "writeMutVar#"  GenPrimOp
 primop  SameMutVarOp "sameMutVar#" GenPrimOp
    MutVar# s a -> MutVar# s a -> Int#
 
--- Note [Why not an unboxed tuple in atomicModifyMutVar#?]
+-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
--- Looking at the type of atomicModifyMutVar#, one might wonder why
+-- Looking at the type of atomicModifyMutVar2#, one might wonder why
 -- it doesn't return an unboxed tuple. e.g.,
 --
---   MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, b #)
+--   MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #)
 --
--- The reason is that atomicModifyMutVar# relies on laziness for its atomicity.
--- Given a MutVar# containing x, atomicModifyMutVar# merely replaces the
+-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity.
+-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces
 -- its contents with a thunk of the form (fst (f x)). This can be done using an
 -- atomic compare-and-swap as it is merely replacing a pointer.
 
-primop  AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp
-   MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #)
-   { Modify the contents of a {\tt MutVar\#}. Note that this isn't strictly
-     speaking the correct type for this function, it should really be
-     {\tt MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #)}, however
-     we don't know about pairs here. }
+primop  AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp
+   MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #)
+   { Modify the contents of a {\tt MutVar\#}, returning the previous
+     contents and the result of applying the given function to the
+     previous contents. Note that this isn't strictly
+     speaking the correct type for this function; it should really be
+     {\tt MutVar\# s a -> (a -> (a,b)) -> State\# s -> (\# State\# s, a, (a, b) \#)},
+     but we don't know about pairs here. }
+   with
+   out_of_line = True
+   has_side_effects = True
+   can_fail         = True
+
+primop  AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp
+   MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)
+   { Modify the contents of a {\tt MutVar\#}, returning the previous
+     contents and the result of applying the given function to the
+     previous contents. }
    with
    out_of_line = True
    has_side_effects = True
@@ -2094,7 +2384,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
--- NB: retry#'s strictness information specifies it to return bottom.
+-- NB: retry#'s strictness information specifies it to throw an exception
 -- This lets the compiler perform some extra simplifications, since retry#
 -- will technically never return.
 --
@@ -2104,10 +2394,13 @@ primop  AtomicallyOp "atomically#" GenPrimOp
 -- with:
 --   retry# s1
 -- where 'e' would be unreachable anyway.  See Trac #8091.
+--
+-- Note that it *does not* return botRes as the "exception" that is thrown may be
+-- "caught" by catchRetry#. This mistake caused #14171.
 primop  RetryOp "retry#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2116,7 +2409,7 @@ primop  CatchRetryOp "catchRetry#" GenPrimOp
    -> (State# RealWorld -> (# State# RealWorld, a #) )
    -> (State# RealWorld -> (# State# RealWorld, a #) )
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
+   strictness  = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
                                                  , lazyApply1Dmd
                                                  , topDmd ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
@@ -2135,13 +2428,6 @@ primop  CatchSTMOp "catchSTM#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
-primop  Check "check#" GenPrimOp
-      (State# RealWorld -> (# State# RealWorld, a #) )
-   -> (State# RealWorld -> State# RealWorld)
-   with
-   out_of_line = True
-   has_side_effects = True
-
 primop  NewTVarOp "newTVar#" GenPrimOp
        a
     -> State# s -> (# State# s, TVar# s a #)
@@ -2352,7 +2638,6 @@ primop  YieldOp "yield#" GenPrimOp
 primop  MyThreadIdOp "myThreadId#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, ThreadId# #)
    with
-   out_of_line = True
    has_side_effects = True
 
 primop LabelThreadOp "labelThread#" GenPrimOp
@@ -2505,13 +2790,13 @@ primop  CompactResizeOp "compactResize#" GenPrimOp
 
 primop  CompactContainsOp "compactContains#" GenPrimOp
    Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
-   { Returns 1# if the object is contained in the compact, 0# otherwise. }
+   { Returns 1\# if the object is contained in the compact, 0\# otherwise. }
    with
    out_of_line      = True
 
 primop  CompactContainsAnyOp "compactContainsAny#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, Int# #)
-   { Returns 1# if the object is in any compact at all, 0# otherwise. }
+   { Returns 1\# if the object is in any compact at all, 0\# otherwise. }
    with
    out_of_line      = True
 
@@ -2592,7 +2877,7 @@ section "Unsafe pointer equality"
 
 primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
    a -> a -> Int#
-   { Returns 1# if the given pointers are equal and 0# otherwise. }
+   { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }
    with
    can_fail   = True -- See Note [reallyUnsafePtrEquality#]
 
@@ -2647,13 +2932,7 @@ primop SparkOp "spark#" GenPrimOp
 
 primop SeqOp "seq#" GenPrimOp
    a -> State# s -> (# State# s, a #)
-
-   -- why return the value?  So that we can control sharing of seq'd
-   -- values: in
-   --    let x = e in x `seq` ... x ...
-   -- we don't want to inline x, so better to represent it as
-   --    let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
-   -- also it matches the type of rseq in the Eval monad.
+   -- See Note [seq# magic] in PrelRules
 
 primop GetSparkOp "getSpark#" GenPrimOp
    State# s -> (# State# s, Int#, a #)
@@ -2675,7 +2954,7 @@ section "Tag to enum stuff"
 ------------------------------------------------------------------------
 
 primop  DataToTagOp "dataToTag#" GenPrimOp
-   a -> Int#
+   a -> Int#  -- Zero-indexed; the first constructor has tag zero
    with
    can_fail   = True -- See Note [dataToTag#]
    strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes }
@@ -2699,7 +2978,7 @@ binder-swap on the case, to give
     \z. case x of y -> let v = dataToTag# x in ...
 
 Now FloatOut might float that v-binding outside the \z.  But that is
-bad because that might mean x gest evaluated much too early!  (CorePrep
+bad because that might mean x gets evaluated much too early!  (CorePrep
 adds an eval to a dataToTag# call, to ensure that the argument really is
 evaluated; see CorePrep Note [dataToTag magic].)
 
@@ -2759,12 +3038,11 @@ primop  NewBCOOp "newBCO#" GenPrimOp
    out_of_line      = True
 
 primop  UnpackClosureOp "unpackClosure#" GenPrimOp
-   a -> (# Addr#, Array# b, ByteArray# #)
-   { {\tt unpackClosure\# closure} copies non-pointers and pointers in the
+   a -> (# Addr#, ByteArray#, Array# b #)
+   { {\tt unpackClosure\# closure} copies the closure and pointers in the
      payload of the given closure into two new arrays, and returns a pointer to
-     the first word of the closure's info table, a pointer array for the
-     pointers in the payload, and a non-pointer array for the non-pointers in
-     the payload. }
+     the first word of the closure's info table, a non-pointer array for the raw
+     bytes of the closure, and a pointer array for the pointers in the payload. }
    with
    out_of_line = True
 
@@ -2785,7 +3063,7 @@ primop  GetCurrentCCSOp "getCurrentCCS#" GenPrimOp
    a -> State# s -> (# State# s, Addr# #)
    { Returns the current {\tt CostCentreStack} (value is {\tt NULL} if
      not profiling).  Takes a dummy argument which can be used to
-     avoid the call to {\tt getCCCS\#} being floated out by the
+     avoid the call to {\tt getCurrentCCS\#} being floated out by the
      simplifier, which would result in an uninformative stack
      ("CAF"). }
 
@@ -2817,8 +3095,9 @@ pseudoop "proxy#"
 pseudoop   "seq"
    a -> b -> b
    { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and
-     otherwise equal to {\tt b}. {\tt seq} is usually introduced to
-     improve performance by avoiding unneeded laziness.
+     otherwise equal to {\tt b}. In other words, it evaluates the first 
+     argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually 
+     introduced to improve performance by avoiding unneeded laziness.
 
      A note on evaluation order: the expression {\tt seq a b} does
      {\it not} guarantee that {\tt a} will be evaluated before {\tt b}.
@@ -2857,7 +3136,7 @@ pseudoop   "unsafeCoerce#"
         {\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also
         an algebraic data type.  For example, do not cast {\tt Int->Int} to {\tt Bool}, even if
         you later cast that {\tt Bool} back to {\tt Int->Int} before applying it.  The reasons
-        have to do with GHC's internal representation details (for the congnoscenti, data values
+        have to do with GHC's internal representation details (for the cognoscenti, data values
         can be entered but function closures cannot).  If you want a safe type to cast things
         to, use {\tt Any}, which is not an algebraic data type.
 
@@ -2875,22 +3154,46 @@ primop  TraceEventOp "traceEvent#" GenPrimOp
    Addr# -> State# s -> State# s
    { Emits an event via the RTS tracing framework.  The contents
      of the event is the zero-terminated byte string passed as the first
-     argument.  The event will be emitted either to the .eventlog file,
+     argument.  The event will be emitted either to the {\tt .eventlog} file,
      or to stderr, depending on the runtime RTS flags. }
    with
    has_side_effects = True
    out_of_line      = True
 
+primop  TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp
+   Addr# -> Int# -> State# s -> State# s
+   { Emits an event via the RTS tracing framework.  The contents
+     of the event is the binary object passed as the first argument with
+     the the given length passed as the second argument. The event will be
+     emitted to the {\tt .eventlog} file. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
 primop  TraceMarkerOp "traceMarker#" GenPrimOp
    Addr# -> State# s -> State# s
    { Emits a marker event via the RTS tracing framework.  The contents
      of the event is the zero-terminated byte string passed as the first
-     argument.  The event will be emitted either to the .eventlog file,
+     argument.  The event will be emitted either to the {\tt .eventlog} file,
      or to stderr, depending on the runtime RTS flags. }
    with
    has_side_effects = True
    out_of_line      = True
 
+primop  GetThreadAllocationCounter "getThreadAllocationCounter#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, INT64 #)
+   { Retrieves the allocation counter for the current thread. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
+   INT64 -> State# RealWorld -> State# RealWorld
+   { Sets the allocation counter for the current thread to the given value. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
 ------------------------------------------------------------------------
 section "Safe coercions"
 ------------------------------------------------------------------------
diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs
index 4dd54dcc6c..91a4ef0ec7 100644
--- a/compiler/profiling/CostCentre.hs
+++ b/compiler/profiling/CostCentre.hs
@@ -1,12 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module CostCentre (
-        CostCentre(..), CcName, IsCafCC(..),
+        CostCentre(..), CcName, CCFlavour(..),
                 -- All abstract except to friend: ParseIface.y
 
         CostCentreStack,
-        CollectedCCs,
-        noCCS, currentCCS, dontCareCCS,
-        noCCSAttached, isCurrentCCS,
+        CollectedCCs, emptyCollectedCCs, collectCC,
+        currentCCS, dontCareCCS,
+        isCurrentCCS,
         maybeSingletonCCS,
 
         mkUserCC, mkAutoCC, mkAllCafsCC,
@@ -20,6 +20,8 @@ module CostCentre (
         cmpCostCentre   -- used for removing dups in a list
     ) where
 
+import GhcPrelude
+
 import Binary
 import Var
 import Name
@@ -29,6 +31,7 @@ import Outputable
 import SrcLoc
 import FastString
 import Util
+import CostCentreState
 
 import Data.Data
 
@@ -39,21 +42,18 @@ import Data.Data
 
 data CostCentre
   = NormalCC {
-                cc_key  :: {-# UNPACK #-} !Int,
+                cc_flavour  :: CCFlavour,
                  -- ^ Two cost centres may have the same name and
                  -- module but different SrcSpans, so we need a way to
                  -- distinguish them easily and give them different
-                 -- object-code labels.  So every CostCentre has a
-                 -- Unique that is distinct from every other
-                 -- CostCentre in the same module.
-                 --
-                 -- XXX: should really be using Unique here, but we
-                 -- need to derive Data below and there's no Data
-                 -- instance for Unique.
+                 -- object-code labels.  So every CostCentre has an
+                 -- associated flavour that indicates how it was
+                 -- generated, and flavours that allow multiple instances
+                 -- of the same name and module have a deterministic 0-based
+                 -- index.
                 cc_name :: CcName,      -- ^ Name of the cost centre itself
                 cc_mod  :: Module,      -- ^ Name of module defining this CC.
-                cc_loc  :: SrcSpan,
-                cc_is_caf  :: IsCafCC   -- see below
+                cc_loc  :: SrcSpan
     }
 
   | AllCafsCC {
@@ -64,9 +64,22 @@ data CostCentre
 
 type CcName = FastString
 
-data IsCafCC = NotCafCC | CafCC
-  deriving (Eq, Ord, Data)
-
+-- | The flavour of a cost centre.
+--
+-- Index fields represent 0-based indices giving source-code ordering of
+-- centres with the same module, name, and flavour.
+data CCFlavour = CafCC -- ^ Auto-generated top-level thunk
+               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression
+               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration
+               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage
+               deriving (Eq, Ord, Data)
+
+-- | Extract the index from a flavour
+flavourIndex :: CCFlavour -> Int
+flavourIndex CafCC = 0
+flavourIndex (ExprCC x) = unCostCentreIndex x
+flavourIndex (DeclCC x) = unCostCentreIndex x
+flavourIndex (HpcCC x) = unCostCentreIndex x
 
 instance Eq CostCentre where
         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
@@ -79,10 +92,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
   = m1 `compare` m2
 
-cmpCostCentre NormalCC {cc_key = n1, cc_mod =  m1}
-              NormalCC {cc_key = n2, cc_mod =  m2}
-    -- first key is module name, then the integer key
-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
+cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}
+              NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}
+    -- first key is module name, then centre name, then flavour
+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
 
 cmpCostCentre other_1 other_2
   = let
@@ -100,9 +113,9 @@ cmpCostCentre other_1 other_2
 -- Predicates on CostCentre
 
 isCafCC :: CostCentre -> Bool
-isCafCC (AllCafsCC {})                 = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _                              = False
+isCafCC (AllCafsCC {})                  = True
+isCafCC (NormalCC {cc_flavour = CafCC}) = True
+isCafCC _                               = False
 
 -- | Is this a cost-centre which records scc counts
 isSccCountCC :: CostCentre -> Bool
@@ -121,18 +134,17 @@ ccFromThisModule cc m = cc_mod cc == m
 -----------------------------------------------------------------------------
 -- Building cost centres
 
-mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
-mkUserCC cc_name mod loc key
-  = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
-               cc_is_caf = NotCafCC {-might be changed-}
+mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
+mkUserCC cc_name mod loc flavour
+  = NormalCC { cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
+               cc_flavour = flavour
     }
 
-mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
-mkAutoCC id mod is_caf
-  = NormalCC { cc_key = getKey (getUnique id),
-               cc_name = str, cc_mod =  mod,
+mkAutoCC :: Id -> Module -> CostCentre
+mkAutoCC id mod
+  = NormalCC { cc_name = str, cc_mod =  mod,
                cc_loc = nameSrcSpan (getName id),
-               cc_is_caf = is_caf
+               cc_flavour = CafCC
     }
   where
         name = getName id
@@ -158,9 +170,7 @@ mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
 --        pre-defined CCSs, see below).
 
 data CostCentreStack
-  = NoCCS
-
-  | CurrentCCS          -- Pinned on a let(rec)-bound
+  = CurrentCCS          -- Pinned on a let(rec)-bound
                         -- thunk/function/constructor, this says that the
                         -- cost centre to be attached to the object, when it
                         -- is allocated, is whatever is in the
@@ -180,24 +190,23 @@ data CostCentreStack
 -- code for a module.
 type CollectedCCs
   = ( [CostCentre]       -- local cost-centres that need to be decl'd
-    , [CostCentre]       -- "extern" cost-centres
     , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
     )
 
+emptyCollectedCCs :: CollectedCCs
+emptyCollectedCCs = ([], [])
 
-noCCS, currentCCS, dontCareCCS :: CostCentreStack
+collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
+collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
+
+currentCCS, dontCareCCS :: CostCentreStack
 
-noCCS                   = NoCCS
 currentCCS              = CurrentCCS
 dontCareCCS             = DontCareCCS
 
 -----------------------------------------------------------------------------
 -- Predicates on Cost-Centre Stacks
 
-noCCSAttached :: CostCentreStack -> Bool
-noCCSAttached NoCCS                     = True
-noCCSAttached _                         = False
-
 isCurrentCCS :: CostCentreStack -> Bool
 isCurrentCCS CurrentCCS                 = True
 isCurrentCCS _                          = False
@@ -221,7 +230,6 @@ mkSingletonCCS cc = SingletonCCS cc
 -- expression.
 
 instance Outputable CostCentreStack where
-  ppr NoCCS             = text "NO_CCS"
   ppr CurrentCCS        = text "CCCS"
   ppr DontCareCCS       = text "CCS_DONT_CARE"
   ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
@@ -251,26 +259,44 @@ instance Outputable CostCentre where
 pprCostCentreCore :: CostCentre -> SDoc
 pprCostCentreCore (AllCafsCC {cc_mod = m})
   = text "__sccC" <+> braces (ppr m)
-pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
-                             cc_is_caf = caf})
+pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
+                             cc_mod = m, cc_loc = loc})
   = text "__scc" <+> braces (hsep [
         ppr m <> char '.' <> ftext n,
-        ifPprDebug (ppr key),
-        pp_caf caf,
-        ifPprDebug (ppr loc)
+        pprFlavourCore flavour,
+        whenPprDebug (ppr loc)
     ])
 
-pp_caf :: IsCafCC -> SDoc
-pp_caf CafCC = text "__C"
-pp_caf _     = empty
+-- ^ Print a flavour in Core
+pprFlavourCore :: CCFlavour -> SDoc
+pprFlavourCore CafCC = text "__C"
+pprFlavourCore f     = pprIdxCore $ flavourIndex f
+
+-- ^ Print a flavour's index in Core
+pprIdxCore :: Int -> SDoc
+pprIdxCore 0 = empty
+pprIdxCore idx = whenPprDebug $ ppr idx
 
 -- Printing as a C label
 ppCostCentreLbl :: CostCentre -> SDoc
 ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
-ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
-                           cc_is_caf = is_caf})
+ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
   = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
-        case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
+        ppFlavourLblComponent f <> text "_cc"
+
+-- ^ Print the flavour component of a C label
+ppFlavourLblComponent :: CCFlavour -> SDoc
+ppFlavourLblComponent CafCC = text "CAF"
+ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
+ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
+ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
+
+-- ^ Print the flavour index component of a C label
+ppIdxLblComponent :: CostCentreIndex -> SDoc
+ppIdxLblComponent n =
+  case unCostCentreIndex n of
+    0 -> empty
+    n -> ppr n
 
 -- This is the name to go in the user-displayed string,
 -- recorded in the cost centre declaration
@@ -279,7 +305,7 @@ costCentreUserName = unpackFS . costCentreUserNameFS
 
 costCentreUserNameFS :: CostCentre -> FastString
 costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
-costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
+costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
   =  case is_caf of
       CafCC -> mkFastString "CAF:" `appendFS` name
       _     -> name
@@ -287,24 +313,32 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
 costCentreSrcSpan :: CostCentre -> SrcSpan
 costCentreSrcSpan = cc_loc
 
-instance Binary IsCafCC where
+instance Binary CCFlavour where
     put_ bh CafCC = do
             putByte bh 0
-    put_ bh NotCafCC = do
+    put_ bh (ExprCC i) = do
             putByte bh 1
+            put_ bh i
+    put_ bh (DeclCC i) = do
+            putByte bh 2
+            put_ bh i
+    put_ bh (HpcCC i) = do
+            putByte bh 3
+            put_ bh i
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CafCC
-              _ -> do return NotCafCC
+              1 -> ExprCC <$> get bh
+              2 -> DeclCC <$> get bh
+              _ -> HpcCC <$> get bh
 
 instance Binary CostCentre where
-    put_ bh (NormalCC aa ab ac _ad ae) = do
+    put_ bh (NormalCC aa ab ac _ad) = do
             putByte bh 0
             put_ bh aa
             put_ bh ab
             put_ bh ac
-            put_ bh ae
     put_ bh (AllCafsCC ae _af) = do
             putByte bh 1
             put_ bh ae
@@ -314,8 +348,7 @@ instance Binary CostCentre where
               0 -> do aa <- get bh
                       ab <- get bh
                       ac <- get bh
-                      ae <- get bh
-                      return (NormalCC aa ab ac noSrcSpan ae)
+                      return (NormalCC aa ab ac noSrcSpan)
               _ -> do ae <- get bh
                       return (AllCafsCC ae noSrcSpan)
 
diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs
new file mode 100644
index 0000000000..0050c1d033
--- /dev/null
+++ b/compiler/profiling/CostCentreState.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module CostCentreState ( CostCentreState, newCostCentreState
+                       , CostCentreIndex, unCostCentreIndex, getCCIndex
+                       ) where
+
+import GhcPrelude
+import FastString
+import FastStringEnv
+
+import Data.Data
+import Binary
+
+-- | Per-module state for tracking cost centre indices.
+--
+-- See documentation of 'CostCentre.cc_flavour' for more details.
+newtype CostCentreState = CostCentreState (FastStringEnv Int)
+
+-- | Initialize cost centre state.
+newCostCentreState :: CostCentreState
+newCostCentreState = CostCentreState emptyFsEnv
+
+-- | An index into a given cost centre module,name,flavour set
+newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }
+  deriving (Eq, Ord, Data, Binary)
+
+-- | Get a new index for a given cost centre name.
+getCCIndex :: FastString
+           -> CostCentreState
+           -> (CostCentreIndex, CostCentreState)
+getCCIndex nm (CostCentreState m) =
+    (CostCentreIndex idx, CostCentreState m')
+  where
+    m_idx = lookupFsEnv m nm
+    idx = maybe 0 id m_idx
+    m' = extendFsEnv m nm (idx + 1)
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
index 9add61e561..931299a655 100644
--- a/compiler/profiling/ProfInit.hs
+++ b/compiler/profiling/ProfInit.hs
@@ -8,11 +8,12 @@
 
 module ProfInit (profilingInitCode) where
 
+import GhcPrelude
+
 import CLabel
 import CostCentre
 import DynFlags
 import Outputable
-import FastString
 import Module
 
 -- -----------------------------------------------------------------------------
@@ -22,25 +23,42 @@ import Module
 -- module;
 
 profilingInitCode :: Module -> CollectedCCs -> SDoc
-profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
+profilingInitCode this_mod (local_CCs, singleton_CCSs)
  = sdocWithDynFlags $ \dflags ->
    if not (gopt Opt_SccProfilingOn dflags)
    then empty
    else vcat
-    [ text "static void prof_init_" <> ppr this_mod
-         <> text "(void) __attribute__((constructor));"
-    , text "static void prof_init_" <> ppr this_mod <> text "(void)"
-    , braces (vcat (
-         map emitRegisterCC           local_CCs ++
-         map emitRegisterCCS          singleton_CCSs
-       ))
-    ]
+    $  map emit_cc_decl local_CCs
+    ++ map emit_ccs_decl singleton_CCSs
+    ++ [emit_cc_list local_CCs]
+    ++ [emit_ccs_list singleton_CCSs]
+    ++ [ text "static void prof_init_" <> ppr this_mod
+            <> text "(void) __attribute__((constructor));"
+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+       , braces (vcat
+                 [ text "registerCcList" <> parens local_cc_list_label <> semi
+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+                 ])
+       ]
  where
-   emitRegisterCC cc   =
-      text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
      where cc_lbl = ppr (mkCCLabel cc)
-   emitRegisterCCS ccs =
-      text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi
+   local_cc_list_label = text "local_cc_" <> ppr this_mod
+   emit_cc_list ccs =
+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
+
+   emit_ccs_decl ccs =
+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
      where ccs_lbl = ppr (mkCCSLabel ccs)
+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
+   emit_ccs_list ccs =
+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs
deleted file mode 100644
index 9704e0b132..0000000000
--- a/compiler/profiling/SCCfinal.hs
+++ /dev/null
@@ -1,285 +0,0 @@
--- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
--- Modify and collect code generation for final STG program
-
-{-
- This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
-
-  - Traverses the STG program collecting the cost centres. These are required
-    to declare the cost centres at the start of code generation.
-
-    Note: because of cross-module unfolding, some of these cost centres may be
-    from other modules.
-
-  - Puts on CAF cost-centres if the user has asked for individual CAF
-    cost-centres.
--}
-
-module SCCfinal ( stgMassageForProfiling ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-
-import CostCentre       -- lots of things
-import Id
-import Name
-import Module
-import UniqSupply       ( UniqSupply )
-import ListSetOps       ( removeDups )
-import Outputable
-import DynFlags
-import CoreSyn          ( Tickish(..) )
-import FastString
-import SrcLoc
-import Util
-
-import Control.Monad (liftM, ap)
-
-stgMassageForProfiling
-        :: DynFlags
-        -> Module                       -- module name
-        -> UniqSupply                   -- unique supply
-        -> [StgTopBinding]              -- input
-        -> (CollectedCCs, [StgTopBinding])
-
-stgMassageForProfiling dflags mod_name _us stg_binds
-  = let
-        ((local_ccs, extern_ccs, cc_stacks),
-         stg_binds2)
-          = initMM mod_name (do_top_bindings stg_binds)
-
-        (fixed_ccs, fixed_cc_stacks)
-          = if gopt Opt_AutoSccsOnIndividualCafs dflags
-            then ([],[])  -- don't need "all CAFs" CC
-            else ([all_cafs_cc], [all_cafs_ccs])
-
-        local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
-        extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
-    in
-    ((fixed_ccs ++ local_ccs_no_dups,
-      extern_ccs_no_dups,
-      fixed_cc_stacks ++ cc_stacks), stg_binds2)
-  where
-
-    span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
-    all_cafs_cc  = mkAllCafsCC mod_name span
-    all_cafs_ccs = mkSingletonCCS all_cafs_cc
-
-    ----------
-    do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]
-
-    do_top_bindings [] = return []
-
-    do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do
-        rhs' <- do_top_rhs b rhs
-        bs' <- do_top_bindings bs
-        return (StgTopLifted (StgNonRec b rhs') : bs')
-
-    do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do
-        pairs2 <- mapM do_pair pairs
-        bs' <- do_top_bindings bs
-        return (StgTopLifted (StgRec pairs2) : bs')
-      where
-        do_pair (b, rhs) = do
-             rhs2 <- do_top_rhs b rhs
-             return (b, rhs2)
-
-    do_top_bindings (b@StgTopStringLit{} : bs) = do
-        bs' <- do_top_bindings bs
-        return (b : bs')
-
-    ----------
-    do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
-
-    do_top_rhs _ (StgRhsClosure _ _ _ _ []
-                     (StgTick (ProfNote _cc False{-not tick-} _push)
-                              (StgConApp con args _)))
-      | not (isDllConApp dflags mod_name con args)
-        -- Trivial _scc_ around nothing but static data
-        -- Eliminate _scc_ ... and turn into StgRhsCon
-
-        -- isDllConApp checks for LitLit args too
-      = return (StgRhsCon dontCareCCS con args)
-
-    do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
-      = do
-        -- Top level CAF without a cost centre attached
-        -- Attach CAF cc (collect if individual CAF ccs)
-        caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
-                   then let cc = mkAutoCC binder modl CafCC
-                            ccs = mkSingletonCCS cc
-                                   -- careful: the binder might be :Main.main,
-                                   -- which doesn't belong to module mod_name.
-                                   -- bug #249, tests prof001, prof002
-                            modl | Just m <- nameModule_maybe (idName binder) = m
-                                 | otherwise = mod_name
-                        in do
-                        collectNewCC  cc
-                        collectCCS ccs
-                        return ccs
-                   else
-                        return all_cafs_ccs
-        body' <- do_expr body
-        return (StgRhsClosure caf_ccs bi fv u [] body')
-
-    do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
-      = do body' <- do_expr body
-           return (StgRhsClosure dontCareCCS bi fv u args body')
-
-    do_top_rhs _ (StgRhsCon _ con args)
-        -- Top-level (static) data is not counted in heap
-        -- profiles; nor do we set CCCS from it; so we
-        -- just slam in dontCareCostCentre
-      = return (StgRhsCon dontCareCCS con args)
-
-    ------
-    do_expr :: StgExpr -> MassageM StgExpr
-
-    do_expr (StgLit l) = return (StgLit l)
-
-    do_expr (StgApp fn args)
-      = return (StgApp fn args)
-
-    do_expr (StgConApp con args ty_args)
-      = return (StgConApp con args ty_args)
-
-    do_expr (StgOpApp con args res_ty)
-      = return (StgOpApp con args res_ty)
-
-    do_expr (StgTick note@(ProfNote cc _ _) expr) = do
-        -- Ha, we found a cost centre!
-        collectCC cc
-        expr' <- do_expr expr
-        return (StgTick note expr')
-
-    do_expr (StgTick ti expr) = do
-        expr' <- do_expr expr
-        return (StgTick ti expr')
-
-    do_expr (StgCase expr bndr alt_type alts) = do
-        expr' <- do_expr expr
-        alts' <- mapM do_alt alts
-        return (StgCase expr' bndr alt_type alts')
-      where
-        do_alt (id, bs, e) = do
-            e' <- do_expr e
-            return (id, bs, e')
-
-    do_expr (StgLet b e) = do
-          (b,e) <- do_let b e
-          return (StgLet b e)
-
-    do_expr (StgLetNoEscape b e) = do
-          (b,e) <- do_let b e
-          return (StgLetNoEscape b e)
-
-    do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
-
-    ----------------------------------
-
-    do_let (StgNonRec b rhs) e = do
-        rhs' <- do_rhs rhs
-        e' <- do_expr e
-        return (StgNonRec b rhs',e')
-
-    do_let (StgRec pairs) e = do
-        pairs' <- mapM do_pair pairs
-        e' <- do_expr e
-        return (StgRec pairs', e')
-      where
-        do_pair (b, rhs) = do
-             rhs2 <- do_rhs rhs
-             return (b, rhs2)
-
-    ----------------------------------
-    do_rhs :: StgRhs -> MassageM StgRhs
-        -- We play much the same game as we did in do_top_rhs above;
-        -- but we don't have to worry about cafs etc.
-
-        -- throw away the SCC if we don't have to count entries.  This
-        -- is a little bit wrong, because we're attributing the
-        -- allocation of the constructor to the wrong place (XXX)
-        -- We should really attach (PushCC cc CurrentCCS) to the rhs,
-        -- but need to reinstate PushCC for that.
-    do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
-               (StgTick (ProfNote cc False{-not tick-} _push)
-                        (StgConApp con args _)))
-      = do collectCC cc
-           return (StgRhsCon currentCCS con args)
-
-    do_rhs (StgRhsClosure _ bi fv u args expr) = do
-        expr' <- do_expr expr
-        return (StgRhsClosure currentCCS bi fv u args expr')
-
-    do_rhs (StgRhsCon _ con args)
-      = return (StgRhsCon currentCCS con args)
-
-
--- -----------------------------------------------------------------------------
--- Boring monad stuff for this
-
-newtype MassageM result
-  = MassageM {
-      unMassageM :: Module              -- module name
-                 -> CollectedCCs
-                 -> (CollectedCCs, result)
-    }
-
-instance Functor MassageM where
-      fmap = liftM
-
-instance Applicative MassageM where
-      pure x = MassageM (\_ ccs -> (ccs, x))
-      (<*>) = ap
-      (*>) = thenMM_
-
-instance Monad MassageM where
-    (>>=) = thenMM
-    (>>)  = (*>)
-
--- the initMM function also returns the final CollectedCCs
-
-initMM :: Module        -- module name, which we may consult
-       -> MassageM a
-       -> (CollectedCCs, a)
-
-initMM mod_name (MassageM m) = m mod_name ([],[],[])
-
-thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
-thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
-
-thenMM expr cont = MassageM $ \mod ccs ->
-    case unMassageM expr mod ccs of { (ccs2, result) ->
-    unMassageM (cont result) mod ccs2 }
-
-thenMM_ expr cont = MassageM $ \mod ccs ->
-    case unMassageM expr mod ccs of { (ccs2, _) ->
-    unMassageM cont mod ccs2 }
-
-
-collectCC :: CostCentre -> MassageM ()
-collectCC cc
- = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
-  -> if (cc `ccFromThisModule` mod_name) then
-        ((cc : local_ccs, extern_ccs, ccss), ())
-     else -- must declare it "extern"
-        ((local_ccs, cc : extern_ccs, ccss), ())
-
--- Version of collectCC used when we definitely want to declare this
--- CC as local, even if its module name is not the same as the current
--- module name (eg. the special :Main module) see bug #249, #1472,
--- test prof001,prof002.
-collectNewCC :: CostCentre -> MassageM ()
-collectNewCC cc
- = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
-              -> ((cc : local_ccs, extern_ccs, ccss), ())
-
-collectCCS :: CostCentreStack -> MassageM ()
-
-collectCCS ccs
- = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
-              -> ASSERT(not (noCCSAttached ccs))
-                       ((local_ccs, extern_ccs, ccs : ccss), ())
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index e18068bc2b..7cd5c55245 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -21,16 +21,17 @@ module RnBinds (
 
    -- Other bindings
    rnMethodBinds, renameSigs,
-   rnMatchGroup, rnGRHSs, rnGRHS,
+   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
    makeMiniFixityEnv, MiniFixityEnv,
    HsSigCtxt(..)
    ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn
 import TcRnMonad
-import TcEvidence     ( emptyTcEvBinds )
 import RnTypes
 import RnPat
 import RnNames
@@ -47,18 +48,19 @@ import NameSet
 import RdrName          ( RdrName, rdrNameOcc )
 import SrcLoc
 import ListSetOps       ( findDupsEq )
-import BasicTypes       ( RecFlag(..), LexicalFixity(..) )
+import BasicTypes       ( RecFlag(..) )
 import Digraph          ( SCC(..) )
 import Bag
 import Util
 import Outputable
-import FastString
 import UniqSet
 import Maybes           ( orElse )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
-import Data.List        ( partition, sort )
+import Data.Foldable      ( toList )
+import Data.List          ( partition, sort )
+import Data.List.NonEmpty ( NonEmpty(..) )
 
 {-
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -180,10 +182,10 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
                -> RnM (HsValBinds GhcRn, DefUses)
 -- A hs-boot file has no bindings.
 -- Return a single HsBindGroup with empty binds and renamed signatures
-rnTopBindsBoot bound_names (ValBindsIn mbinds sigs)
+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
   = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
         ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
-        ; return (ValBindsOut [] sigs', usesOnly fvs) }
+        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
 rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
 
 {-
@@ -200,27 +202,31 @@ rnLocalBindsAndThen :: HsLocalBinds GhcPs
 -- This version (a) assumes that the binding vars are *not* already in scope
 --               (b) removes the binders from the free vars of the thing inside
 -- The parser doesn't produce ThenBinds
-rnLocalBindsAndThen EmptyLocalBinds thing_inside =
-  thing_inside EmptyLocalBinds emptyNameSet
+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
+  thing_inside (EmptyLocalBinds x) emptyNameSet
 
-rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
+rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
   = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
-      thing_inside (HsValBinds val_binds')
+      thing_inside (HsValBinds x val_binds')
 
-rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
     (binds',fv_binds) <- rnIPBinds binds
-    (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds
+    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
     return (thing, fvs_thing `plusFV` fv_binds)
 
+rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
+
 rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
-rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
+rnIPBinds (IPBinds _ ip_binds ) = do
     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
-    return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
+    return (IPBinds noExt ip_binds', plusFVs fvs_s)
+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
 
 rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
-rnIPBind (IPBind ~(Left n) expr) = do
+rnIPBind (IPBind _ ~(Left n) expr) = do
     (expr',fvExpr) <- rnLExpr expr
-    return (IPBind (Left n) expr', fvExpr)
+    return (IPBind noExt (Left n) expr', fvExpr)
+rnIPBind (XIPBind _) = panic "rnIPBind"
 
 {-
 ************************************************************************
@@ -271,9 +277,9 @@ rnLocalValBindsLHS fix_env binds
 rnValBindsLHS :: NameMaker
               -> HsValBinds GhcPs
               -> RnM (HsValBindsLR GhcRn GhcPs)
-rnValBindsLHS topP (ValBindsIn mbinds sigs)
+rnValBindsLHS topP (ValBinds x mbinds sigs)
   = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
-       ; return $ ValBindsIn mbinds' sigs }
+       ; return $ ValBinds x mbinds' sigs }
   where
     bndrs = collectHsBindsBinders mbinds
     doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
@@ -288,12 +294,12 @@ rnValBindsRHS :: HsSigCtxt
               -> HsValBindsLR GhcRn GhcPs
               -> RnM (HsValBinds GhcRn, DefUses)
 
-rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
+rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
   = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
-       ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
+       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
        ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
 
-       ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $
+       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
                           getPatSynBinds anal_binds
                 -- The uses in binds_w_dus for PatSynBinds do not include
                 -- variables used in the patsyn builders; see
@@ -308,7 +314,7 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
                             -- so that the binders are removed from
                             -- the uses in the sigs
 
-        ; return (ValBindsOut anal_binds sigs', valbind'_dus) }
+        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
 
 rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
 
@@ -333,10 +339,10 @@ rnLocalValBindsAndThen
   :: HsValBinds GhcPs
   -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
   -> RnM (result, FreeVars)
-rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
  = do   {     -- (A) Create the local fixity environment
-          new_fixities <- makeMiniFixityEnv [L loc sig
-                                                  | L loc (FixSig sig) <- sigs]
+          new_fixities <- makeMiniFixityEnv [ L loc sig
+                                            | L loc (FixSig _ sig) <- sigs]
 
               -- (B) Rename the LHSes
         ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
@@ -402,27 +408,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
   = do
       -- we don't actually use the FV processing of rnPatsAndThen here
       (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })
+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
                 -- We temporarily store the pat's FVs in bind_fvs;
                 -- gets updated to the FVs of the whole bind
                 -- when doing the RHS below
 
 rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
   = do { name <- applyNameMaker name_maker rdr_name
-       ; return (bind { fun_id   = name
-                      , bind_fvs = placeHolderNamesTc }) }
+       ; return (bind { fun_id = name
+                      , fun_ext = noExt }) }
 
-rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
+rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
   | isTopRecNameMaker name_maker
   = do { addLocM checkConName rdrname
        ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
-       ; return (PatSynBind psb{ psb_id = name }) }
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
 
   | otherwise  -- Pattern synonym, not at top level
   = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
                                         -- name so that we can carry on
        ; name <- applyNameMaker name_maker rdrname
-       ; return (PatSynBind psb{ psb_id = name }) }
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
   where
     localPatternSynonymErr :: SDoc
     localPatternSynonymErr
@@ -447,7 +453,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat
                        , pat_rhs = grhss
                                    -- pat fvs were stored in bind_fvs
                                    -- after processing the LHS
-                       , bind_fvs = pat_fvs })
+                       , pat_ext = pat_fvs })
   = do  { mod <- getModule
         ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
 
@@ -459,14 +465,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat
                 -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
               bndrs = collectPatBinders pat
               bind' = bind { pat_rhs  = grhss'
-                           , pat_rhs_ty = placeHolderType, bind_fvs = fvs' }
+                           , pat_ext = fvs' }
 
               ok_nobind_pat
                   = -- See Note [Pattern bindings that bind no variables]
                     case pat of
-                       L _ (WildPat {}) -> True
-                       L _ (BangPat {}) -> True -- #9127, #13646
-                       _                -> False
+                       L _ (WildPat {})   -> True
+                       L _ (BangPat {})   -> True -- #9127, #13646
+                       L _ (SplicePat {}) -> True
+                       _                  -> False
 
         -- Warn if the pattern binds no variables
         -- See Note [Pattern bindings that bind no variables]
@@ -498,13 +505,13 @@ rnBind sig_fn bind@(FunBind { fun_id = name
 
         ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind { fun_matches = matches'
-                       , bind_fvs   = fvs' },
+                       , fun_ext     = fvs' },
                   [plain_name], rhs_fvs)
       }
 
-rnBind sig_fn (PatSynBind bind)
+rnBind sig_fn (PatSynBind x bind)
   = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
-        ; return (PatSynBind bind', name, fvs) }
+        ; return (PatSynBind x bind', name, fvs) }
 
 rnBind _ b = pprPanic "rnBind" (ppr b)
 
@@ -512,7 +519,7 @@ rnBind _ b = pprPanic "rnBind" (ppr b)
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Generally, we want to warn about pattern bindings like
   Just _ = e
-because they don't do anything!  But we have two exceptions:
+because they don't do anything!  But we have three exceptions:
 
 * A wildcard pattern
        _ = rhs
@@ -526,6 +533,12 @@ because they don't do anything!  But we have two exceptions:
   Moreover, Trac #13646 argues that even for single constructor
   types, you might want to write the constructor.  See also #9127.
 
+* A splice pattern
+      $(th-lhs) = rhs
+   It is impossible to determine whether or not th-lhs really
+   binds any variable. We should disable the warning for any pattern
+   which contain splices, but that is a more expensive check.
+
 Note [Free-variable space leak]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We have
@@ -568,31 +581,31 @@ depAnalBinds binds_w_dus
 
 ---------------------
 -- Bind the top-level forall'd type variables in the sigs.
--- E.g  f :: a -> a
+-- E.g  f :: forall a. a -> a
 --      f = rhs
 --      The 'a' scopes over the rhs
 --
 -- NB: there'll usually be just one (for a function binding)
 --     but if there are many, one may shadow the rest; too bad!
---      e.g  x :: [a] -> [a]
---           y :: [(a,a)] -> a
+--      e.g  x :: forall a. [a] -> [a]
+--           y :: forall a. [(a,a)] -> a
 --           (x,y) = e
 --      In e, 'a' will be in scope, and it'll be the one from 'y'!
 
-mkSigTvFn :: [LSig GhcRn] -> (Name -> [Name])
+mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
 -- Return a lookup function that maps an Id Name to the names
 -- of the type variables that should scope over its body.
-mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
   where
     env = mkHsSigEnv get_scoped_tvs sigs
 
     get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
     -- Returns (binders, scoped tvs for those binders)
-    get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
+    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
       = Just (names, hsScopedTvs sig_ty)
-    get_scoped_tvs (L _ (TypeSig names sig_ty))
+    get_scoped_tvs (L _ (TypeSig _ names sig_ty))
       = Just (names, hsWcScopedTvs sig_ty)
-    get_scoped_tvs (L _ (PatSynSig names sig_ty))
+    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
       = Just (names, hsScopedTvs sig_ty)
     get_scoped_tvs _ = Nothing
 
@@ -607,9 +620,10 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
 
 makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
  where
-   add_one_sig env (L loc (FixitySig names fixity)) =
+   add_one_sig env (L loc (FixitySig _ names fixity)) =
      foldlM add_one env [ (loc,name_loc,name,fixity)
                         | L name_loc name <- names ]
+   add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
 
    add_one env (loc, name_loc, name,fixity) = do
      { -- this fixity decl is a duplicate iff
@@ -649,27 +663,27 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
        -- invariant: no free vars here when it's a FunBind
   = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
         ; unless pattern_synonym_ok (addErr patternSynonymErr)
-        ; let sig_tvs = sig_fn name
+        ; let scoped_tvs = sig_fn name
 
-        ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $
+        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
                                       rnPat PatSyn pat $ \pat' ->
          -- We check the 'RdrName's instead of the 'Name's
          -- so that the binding locations are reported
          -- from the left-hand side
             case details of
-               PrefixPatSyn vars ->
+               PrefixCon vars ->
                    do { checkDupRdrNames vars
                       ; names <- mapM lookupPatSynBndr vars
-                      ; return ( (pat', PrefixPatSyn names)
+                      ; return ( (pat', PrefixCon names)
                                , mkFVs (map unLoc names)) }
-               InfixPatSyn var1 var2 ->
+               InfixCon var1 var2 ->
                    do { checkDupRdrNames [var1, var2]
                       ; name1 <- lookupPatSynBndr var1
                       ; name2 <- lookupPatSynBndr var2
                       -- ; checkPrecMatch -- TODO
-                      ; return ( (pat', InfixPatSyn name1 name2)
+                      ; return ( (pat', InfixCon name1 name2)
                                , mkFVs (map unLoc [name1, name2])) }
-               RecordPatSyn vars ->
+               RecCon vars ->
                    do { checkDupRdrNames (map recordPatSynSelectorId vars)
                       ; let rnRecordPatSynField
                               (RecordPatSynField { recordPatSynSelectorId = visible
@@ -679,14 +693,14 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                                    ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
                                                                 , recordPatSynPatVar = hidden' } }
                       ; names <- mapM rnRecordPatSynField  vars
-                      ; return ( (pat', RecordPatSyn names)
+                      ; return ( (pat', RecCon names)
                                , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
 
         ; (dir', fvs2) <- case dir of
             Unidirectional -> return (Unidirectional, emptyFVs)
             ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
             ExplicitBidirectional mg ->
-                do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
+                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
                                    rnMatchGroup (mkPrefixFunRhs (L l name))
                                                 rnLExpr mg
                    ; return (ExplicitBidirectional mg', fvs) }
@@ -701,9 +715,9 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
               bind' = bind{ psb_args = details'
                           , psb_def = pat'
                           , psb_dir = dir'
-                          , psb_fvs = fvs' }
+                          , psb_ext = fvs' }
               selector_names = case details' of
-                                 RecordPatSyn names ->
+                                 RecCon names ->
                                   map (unLoc . recordPatSynSelectorId) names
                                  _ -> []
 
@@ -720,6 +734,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
       = hang (text "Illegal pattern synonym declaration")
            2 (text "Use -XPatternSynonyms to enable this extension")
 
+rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
+
 {-
 Note [Renaming pattern synonym variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -851,7 +867,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
        -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
        ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables
        ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
-              do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds'
+              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
                  ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
                                            emptyFVs binds_w_dus
                  ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
@@ -873,9 +889,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
   = setSrcSpan loc $ do
     do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
                      -- We use the selector name as the binder
-       ; let bind' = bind { fun_id = sel_name
-                          , bind_fvs = placeHolderNamesTc }
-
+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
        ; return (L loc bind' `consBag` rest ) }
 
 -- Report error for all other forms of bindings
@@ -938,42 +952,41 @@ renameSigs ctxt sigs
 -- Doesn't seem worth much trouble to sort this.
 
 renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
--- FixitySig is renamed elsewhere.
-renameSig _ (IdSig x)
-  = return (IdSig x, emptyFVs)    -- Actually this never occurs
+renameSig _ (IdSig _ x)
+  = return (IdSig noExt x, emptyFVs)    -- Actually this never occurs
 
-renameSig ctxt sig@(TypeSig vs ty)
+renameSig ctxt sig@(TypeSig _ vs ty)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
         ; (new_ty, fvs) <- rnHsSigWcType doc ty
-        ; return (TypeSig new_vs new_ty, fvs) }
+        ; return (TypeSig noExt new_vs new_ty, fvs) }
 
-renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
+renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
         ; when (is_deflt && not defaultSigs_on) $
           addErr (defaultSigErr sig)
         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
         ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
-        ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
+        ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
   where
     (v1:_) = vs
     ty_ctxt = GenericCtx (text "a class method signature for"
                           <+> quotes (ppr v1))
 
-renameSig _ (SpecInstSig src ty)
+renameSig _ (SpecInstSig _ src ty)
   = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
-        ; return (SpecInstSig src new_ty,fvs) }
+        ; return (SpecInstSig noExt src new_ty,fvs) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
 -- so, in the top-level case (when mb_names is Nothing)
 -- we use lookupOccRn.  If there's both an imported and a local 'f'
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig ctxt sig@(SpecSig v tys inl)
+renameSig ctxt sig@(SpecSig _ v tys inl)
   = do  { new_v <- case ctxt of
                      TopSigCtxt {} -> lookupLocatedOccRn v
                      _             -> lookupSigOccRn ctxt sig v
         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
-        ; return (SpecSig new_v new_ty inl, fvs) }
+        ; return (SpecSig noExt new_v new_ty inl, fvs) }
   where
     ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
                           <+> quotes (ppr v))
@@ -981,33 +994,33 @@ renameSig ctxt sig@(SpecSig v tys inl)
       = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
 
-renameSig ctxt sig@(InlineSig v s)
+renameSig ctxt sig@(InlineSig _ v s)
   = do  { new_v <- lookupSigOccRn ctxt sig v
-        ; return (InlineSig new_v s, emptyFVs) }
+        ; return (InlineSig noExt new_v s, emptyFVs) }
 
-renameSig ctxt sig@(FixSig (FixitySig vs f))
-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
-        ; return (FixSig (FixitySig new_vs f), emptyFVs) }
+renameSig ctxt (FixSig _ fsig)
+  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig
+        ; return (FixSig noExt new_fsig, emptyFVs) }
 
-renameSig ctxt sig@(MinimalSig s (L l bf))
+renameSig ctxt sig@(MinimalSig _ s (L l bf))
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
-       return (MinimalSig s (L l new_bf), emptyFVs)
+       return (MinimalSig noExt s (L l new_bf), emptyFVs)
 
-renameSig ctxt sig@(PatSynSig vs ty)
+renameSig ctxt sig@(PatSynSig _ vs ty)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
         ; (ty', fvs) <- rnHsSigType ty_ctxt ty
-        ; return (PatSynSig new_vs ty', fvs) }
+        ; return (PatSynSig noExt new_vs ty', fvs) }
   where
     ty_ctxt = GenericCtx (text "a pattern synonym signature for"
                           <+> ppr_sig_bndrs vs)
 
-renameSig ctxt sig@(SCCFunSig st v s)
+renameSig ctxt sig@(SCCFunSig _ st v s)
   = do  { new_v <- lookupSigOccRn ctxt sig v
-        ; return (SCCFunSig st new_v s, emptyFVs) }
+        ; return (SCCFunSig noExt st new_v s, emptyFVs) }
 
 -- COMPLETE Sigs can refer to imported IDs which is why we use
 -- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
   = do new_bf <- traverse lookupLocatedOccRn bf
        new_mty  <- traverse lookupLocatedOccRn mty
 
@@ -1016,7 +1029,7 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
          -- Why 'any'? See Note [Orphan COMPLETE pragmas]
          addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
 
-       return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
+       return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
   where
     orphanError :: SDoc
     orphanError =
@@ -1024,6 +1037,8 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
       text "A COMPLETE pragma must mention at least one data constructor" $$
       text "or pattern synonym defined in the same module."
 
+renameSig _ (XSig _) = panic "renameSig"
+
 {-
 Note [Orphan COMPLETE pragmas]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1090,8 +1105,10 @@ okHsSig ctxt (L _ sig)
      (CompleteMatchSig {}, TopSigCtxt {} ) -> True
      (CompleteMatchSig {}, _)              -> False
 
+     (XSig _, _) -> panic "okHsSig"
+
 -------------------
-findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
 -- Check for duplicates on RdrName version,
 -- because renamed version has unboundName for
 -- not-in-scope binders, which gives bogus dup-sig errors
@@ -1103,20 +1120,20 @@ findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
 findDupSigs sigs
   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
   where
-    expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
-    expand_sig sig@(InlineSig n _)           = [(n,sig)]
-    expand_sig sig@(TypeSig ns _)            = [(n,sig) | n <- ns]
-    expand_sig sig@(ClassOpSig _ ns _)       = [(n,sig) | n <- ns]
-    expand_sig sig@(PatSynSig ns  _ )        = [(n,sig) | n <- ns]
-    expand_sig sig@(SCCFunSig _ n _)         = [(n,sig)]
+    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
+    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]
+    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]
+    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]
+    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]
+    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]
     expand_sig _ = []
 
     matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
     mtch (FixSig {})           (FixSig {})         = True
     mtch (InlineSig {})        (InlineSig {})      = True
     mtch (TypeSig {})          (TypeSig {})        = True
-    mtch (ClassOpSig d1 _ _)   (ClassOpSig d2 _ _) = d1 == d2
-    mtch (PatSynSig _ _)       (PatSynSig _ _)     = True
+    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
+    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True
     mtch (SCCFunSig{})         (SCCFunSig{})       = True
     mtch _ _ = False
 
@@ -1144,6 +1161,7 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
        ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
        ; return (mkMatchGroup origin new_ms, ms_fvs) }
+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
 
 rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1155,24 +1173,17 @@ rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
          -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
          -> Match GhcPs (Located (body GhcPs))
          -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
-rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
-                                  , m_type = maybe_rhs_sig, m_grhss = grhss })
-  = do  {       -- Result type signatures are no longer supported
-          case maybe_rhs_sig of
-                Nothing -> return ()
-                Just (L loc ty) -> addErrAt loc (resSigErr match ty)
-
-        ; let fixity = if isInfixMatch match then Infix else Prefix
-               -- Now the main event
-               -- Note that there are no local fixity decls for matches
+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
+  = do  { -- Note that there are no local fixity decls for matches
         ; rnPats ctxt pats      $ \ pats' -> do
         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
-        ; let mf' = case (ctxt,mf) of
-                      (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict)
-                                            -> FunRhs (L lf funid) fixity strict
+        ; let mf' = case (ctxt, mf) of
+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
+                                            -> mf { mc_fun = L lf funid }
                       _                     -> ctxt
-        ; return (Match { m_ctxt = mf', m_pats = pats'
-                        , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
+        ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
+                        , m_grhss = grhss'}, grhss_fvs ) }}
+rnMatch' _ _ (XMatch _) = panic "rnMatch'"
 
 emptyCaseErr :: HsMatchContext Name -> SDoc
 emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
@@ -1183,15 +1194,6 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
                 LambdaExpr -> text "\\case expression"
                 _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
 
-
-resSigErr :: Outputable body
-          => Match GhcPs body -> HsType GhcPs -> SDoc
-resSigErr match ty
-   = vcat [ text "Illegal result type signature" <+> quotes (ppr ty)
-          , nest 2 $ ptext (sLit
-                 "Result signatures are no longer supported in pattern matches")
-          , pprMatchInCtxt match ]
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1204,10 +1206,11 @@ rnGRHSs :: HsMatchContext Name
         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
         -> GRHSs GhcPs (Located (body GhcPs))
         -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))
+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
   = rnLocalBindsAndThen binds   $ \ binds' _ -> do
     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
-    return (GRHSs grhss' (L l binds'), fvGRHSs)
+    return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
 
 rnGRHS :: HsMatchContext Name
        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1219,7 +1222,7 @@ rnGRHS' :: HsMatchContext Name
         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
         -> GRHS GhcPs (Located (body GhcPs))
         -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHS' ctxt rnBody (GRHS guards rhs)
+rnGRHS' ctxt rnBody (GRHS _ guards rhs)
   = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards
         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
                                     rnBody rhs
@@ -1227,14 +1230,48 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
         ; unless (pattern_guards_allowed || is_standard_guard guards')
                  (addWarn NoReason (nonStdGuardErr guards'))
 
-        ; return (GRHS guards' rhs', fvs) }
+        ; return (GRHS noExt guards' rhs', fvs) }
   where
         -- Standard Haskell 1.4 guards are just a single boolean
         -- expression, rather than a list of qualifiers as in the
         -- Glasgow extension
-    is_standard_guard []                       = True
-    is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
-    is_standard_guard _                        = False
+    is_standard_guard []                  = True
+    is_standard_guard [L _ (BodyStmt {})] = True
+    is_standard_guard _                   = False
+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
+
+{-
+*********************************************************
+*                                                       *
+        Source-code fixity declarations
+*                                                       *
+*********************************************************
+-}
+
+rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
+-- Rename a fixity decl, so we can put
+-- the renamed decl in the renamed syntax tree
+-- Errors if the thing being fixed is not defined locally.
+rnSrcFixityDecl sig_ctxt = rn_decl
+  where
+    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
+        -- GHC extension: look up both the tycon and data con
+        -- for con-like things; hence returning a list
+        -- If neither are in scope, report an error; otherwise
+        -- return a fixity sig for each (slightly odd)
+    rn_decl (FixitySig _ fnames fixity)
+      = do names <- concatMapM lookup_one fnames
+           return (FixitySig noExt names fixity)
+    rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
+
+    lookup_one :: Located RdrName -> RnM [Located Name]
+    lookup_one (L name_loc rdr_name)
+      = setSrcSpan name_loc $
+                    -- This lookup will fail if the name is not defined in the
+                    -- same binding group as this fixity declaration.
+        do names <- lookupLocalTcNames sig_ctxt what rdr_name
+           return [ L name_loc name | (_, name) <- names ]
+    what = text "fixity signature"
 
 {-
 ************************************************************************
@@ -1244,17 +1281,18 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
 ************************************************************************
 -}
 
-dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM ()
-dupSigDeclErr pairs@((L loc name, sig) : _)
+dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
+dupSigDeclErr pairs@((L loc name, sig) :| _)
   = addErrAt loc $
     vcat [ text "Duplicate" <+> what_it_is
            <> text "s for" <+> quotes (ppr name)
-         , text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
+         , text "at" <+> vcat (map ppr $ sort
+                                       $ map (getLoc . fst)
+                                       $ toList pairs)
+         ]
   where
     what_it_is = hsSigDoc sig
 
-dupSigDeclErr [] = panic "dupSigDeclErr"
-
 misplacedSigErr :: LSig GhcRn -> RnM ()
 misplacedSigErr (L loc sig)
   = addErrAt loc $
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 617b3556bb..16897c2681 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -13,14 +13,13 @@ module RnEnv (
         lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
         lookupLocalOccRn_maybe, lookupInfoOccRn,
         lookupLocalOccThLvl_maybe, lookupLocalOccRn,
-        lookupTypeOccRn, lookupKindOccRn,
+        lookupTypeOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
         lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
 
-        lookupSubBndrOcc_helper,
         ChildLookupResult(..),
-
-        combineChildLookupResult,
+        lookupSubBndrOcc_helper,
+        combineChildLookupResult, -- Called by lookupChildrenExport
 
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
         lookupSigCtxtOccRn,
@@ -45,6 +44,8 @@ module RnEnv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )
 import IfaceEnv
 import HsSyn
@@ -53,7 +54,7 @@ import HscTypes
 import TcEnv
 import TcRnMonad
 import RdrHsSyn         ( setRdrNameSpace )
-import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )
+import TysWiredIn
 import Name
 import NameSet
 import NameEnv
@@ -62,8 +63,8 @@ import Module
 import ConLike
 import DataCon
 import TyCon
+import ErrUtils         ( MsgDoc )
 import PrelNames        ( rOOT_MAIN )
-import ErrUtils         ( MsgDoc, ErrMsg )
 import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))
 import SrcLoc
 import Outputable
@@ -76,8 +77,10 @@ import ListSetOps       ( minusList )
 import qualified GHC.LanguageExtensions as LangExt
 import RnUnbound
 import RnUtils
-import Data.Functor (($>))
 import Data.Maybe (isJust)
+import qualified Data.Semigroup as Semi
+import Data.Either      ( partitionEithers )
+import Data.List        (find)
 
 {-
 *********************************************************
@@ -193,7 +196,7 @@ newTopSrcBinder (L loc rdr_name)
   = do  { when (isQual rdr_name)
                  (addErrAt loc (badQualBndrErr rdr_name))
                 -- Binders should not be qualified; if they are, and with a different
-                -- module name, we we get a confusing "M.T is not in scope" error later
+                -- module name, we get a confusing "M.T is not in scope" error later
 
         ; stage <- getStage
         ; if isBrackStage stage then
@@ -430,34 +433,122 @@ lookupExactOrOrig rdr_name res k
 
 
 -----------------------------------------------
--- Used for record construction and pattern matching
--- When the -XDisambiguateRecordFields flag is on, take account of the
--- constructor name to disambiguate which field to use; it's just the
--- same as for instance decls
+-- | Look up an occurrence of a field in record construction or pattern
+-- matching (but not update).  When the -XDisambiguateRecordFields
+-- flag is on, take account of the data constructor name to
+-- disambiguate which field to use.
 --
--- NB: Consider this:
---      module Foo where { data R = R { fld :: Int } }
---      module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-
-lookupRecFieldOcc :: Maybe Name -- Nothing    => just look it up as usual
-                                      -- Just tycon => use tycon to disambiguate
-                  -> SDoc -> RdrName
+-- See Note [DisambiguateRecordFields].
+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual
+                                -- Just con => use data con to disambiguate
+                  -> RdrName
                   -> RnM Name
-lookupRecFieldOcc parent doc rdr_name
-  | Just tc_name <- parent
-  = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name
-       ; case mb_name of
-           Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
-           Right n  -> return n }
-
+lookupRecFieldOcc mb_con rdr_name
+  | Just con <- mb_con
+  , isUnboundName con  -- Avoid error cascade
+  = return (mkUnboundNameRdr rdr_name)
+  | Just con <- mb_con
+  = do { flds <- lookupConstructorFields con
+       ; env <- getGlobalRdrEnv
+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)
+             mb_field = do fl <- find ((== lbl) . flLabel) flds
+                           -- We have the label, now check it is in
+                           -- scope (with the correct qualifier if
+                           -- there is one, hence calling pickGREs).
+                           gre <- lookupGRE_FieldLabel env fl
+                           guard (not (isQual rdr_name
+                                         && null (pickGREs rdr_name [gre])))
+                           return (fl, gre)
+       ; case mb_field of
+           Just (fl, gre) -> do { addUsedGRE True gre
+                                ; return (flSelector fl) }
+           Nothing        -> lookupGlobalOccRn rdr_name }
+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
   | otherwise
   -- This use of Global is right as we are looking up a selector which
   -- can only be defined at the top level.
   = lookupGlobalOccRn rdr_name
 
+{- Note [DisambiguateRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking up record fields in record construction or pattern
+matching, we can take advantage of the data constructor name to
+resolve fields that would otherwise be ambiguous (provided the
+-XDisambiguateRecordFields flag is on).
+
+For example, consider:
+
+   data S = MkS { x :: Int }
+   data T = MkT { x :: Int }
+
+   e = MkS { x = 3 }
+
+When we are renaming the occurrence of `x` in `e`, instead of looking
+`x` up directly (and finding both fields), lookupRecFieldOcc will
+search the fields of `MkS` to find the only possible `x` the user can
+mean.
+
+Of course, we still have to check the field is in scope, using
+lookupGRE_FieldLabel.  The handling of qualified imports is slightly
+subtle: the occurrence may be unqualified even if the field is
+imported only qualified (but if the occurrence is qualified, the
+qualifier must be correct). For example:
+
+   module A where
+     data S = MkS { x :: Int }
+     data T = MkT { x :: Int }
+
+   module B where
+     import qualified A (S(..))
+     import A (T(MkT))
+
+     e1 = MkT   { x = 3 }   -- x not in scope, so fail
+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)
+
+In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,
+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
+will fail because the field RdrName `B.x` is qualified and pickGREs
+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the
+GRE for `A.x` and the guard will succeed because the field RdrName `x`
+is unqualified.
+
+
+Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we fail to find the field or it is not in scope, mb_field
+will be False, and we fall back on looking it up normally using
+lookupGlobalOccRn.  We don't report an error immediately because the
+actual problem might be located elsewhere.  For example (Trac #9975):
+
+   data Test = Test { x :: Int }
+   pattern Test wat = Test { x = wat }
+
+Here there are multiple declarations of Test (as a data constructor
+and as a pattern synonym), which will be reported as an error.  We
+shouldn't also report an error about the occurrence of `x` in the
+pattern synonym RHS.  However, if the pattern synonym gets added to
+the environment first, we will try and fail to find `x` amongst the
+(nonexistent) fields of the pattern synonym.
+
+Alternatively, the scope check can fail due to Template Haskell.
+Consider (Trac #12130):
+
+   module Foo where
+     import M
+     b = $(funny)
+
+   module M(funny) where
+     data T = MkT { x :: Int }
+     funny :: Q Exp
+     funny = [| MkT { x = 3 } |]
+
+When we splice, `MkT` is not lexically in scope, so
+lookupGRE_FieldLabel will fail.  But there is no need for
+disambiguation anyway, because `x` is an original name, and
+lookupGlobalOccRn will find it.
+-}
+
 
 
 -- | Used in export lists to lookup the children.
@@ -584,32 +675,32 @@ instance Outputable DisambigInfo where
   ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
   ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres
 
-instance Monoid DisambigInfo where
-  mempty = NoOccurrence
+instance Semi.Semigroup DisambigInfo where
   -- This is the key line: We prefer disambiguated occurrences to other
   -- names.
-  _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
-  DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g'
-
+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
 
-  NoOccurrence `mappend` m = m
-  m `mappend` NoOccurrence = m
-  UniqueOccurrence g `mappend` UniqueOccurrence g'
+  NoOccurrence <> m = m
+  m <> NoOccurrence = m
+  UniqueOccurrence g <> UniqueOccurrence g'
     = AmbiguousOccurrence [g, g']
-  UniqueOccurrence g `mappend` AmbiguousOccurrence gs
+  UniqueOccurrence g <> AmbiguousOccurrence gs
     = AmbiguousOccurrence (g:gs)
-  AmbiguousOccurrence gs `mappend` UniqueOccurrence g'
+  AmbiguousOccurrence gs <> UniqueOccurrence g'
     = AmbiguousOccurrence (g':gs)
-  AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs'
+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
     = AmbiguousOccurrence (gs ++ gs')
+
+instance Monoid DisambigInfo where
+  mempty = NoOccurrence
+  mappend = (Semi.<>)
+
 -- Lookup SubBndrOcc can never be ambiguous
 --
 -- Records the result of looking up a child.
 data ChildLookupResult
       = NameNotFound                --  We couldn't find a suitable name
-      | NameErr ErrMsg              --  We found an unambiguous name
-                                    --  but there's another error
-                                    --  we should abort from
       | IncorrectParent Name        -- Parent
                         Name        -- Name of thing we were looking for
                         SDoc        -- How to print the name
@@ -628,9 +719,8 @@ combineChildLookupResult (x:xs) = do
 
 instance Outputable ChildLookupResult where
   ppr NameNotFound = text "NameNotFound"
-  ppr (FoundName _p n) = text "Found:" <+> ppr n
+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n
   ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
-  ppr (NameErr _) = text "Error"
   ppr (IncorrectParent p n td ns) = text "IncorrectParent"
                                   <+> hsep [ppr p, ppr n, td, ppr ns]
 
@@ -650,9 +740,10 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
     NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
     FoundName _p n -> return (Right n)
     FoundFL fl  ->  return (Right (flSelector fl))
-    NameErr err ->  reportError err $> (Right $ mkUnboundNameRdr rdr_name)
-    IncorrectParent {} -> return $ Left (unknownSubordinateErr doc rdr_name)
-
+    IncorrectParent {}
+         -- See [Mismatched class methods and associated type families]
+         -- in TcInstDecls.
+      -> return $ Left (unknownSubordinateErr doc rdr_name)
 
 {-
 Note [Family instance binders]
@@ -822,20 +913,6 @@ lookupLocalOccRn rdr_name
            Just name -> return name
            Nothing   -> unboundName WL_LocalOnly rdr_name }
 
-lookupKindOccRn :: RdrName -> RnM Name
--- Looking up a name occurring in a kind
-lookupKindOccRn rdr_name
-  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
-  = badVarInType rdr_name
-  | otherwise
-  = do { typeintype <- xoptM LangExt.TypeInType
-       ; if | typeintype           -> lookupTypeOccRn rdr_name
-      -- With -XNoTypeInType, treat any usage of * in kinds as in scope
-      -- this is a dirty hack, but then again so was the old * kind.
-            | isStar rdr_name     -> return starKindTyConName
-            | isUniStar rdr_name -> return unicodeStarKindTyConName
-            | otherwise            -> lookupOccRn rdr_name }
-
 -- lookupPromotedOccRn looks up an optionally promoted RdrName.
 lookupTypeOccRn :: RdrName -> RnM Name
 -- see Note [Demotion]
@@ -844,16 +921,17 @@ lookupTypeOccRn rdr_name
   = badVarInType rdr_name
   | otherwise
   = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; case mb_name of {
-             Just name -> return name ;
-             Nothing   -> do { dflags <- getDynFlags
-                             ; lookup_demoted rdr_name dflags } } }
+       ; case mb_name of
+             Just name -> return name
+             Nothing   -> lookup_demoted rdr_name }
 
-lookup_demoted :: RdrName -> DynFlags -> RnM Name
-lookup_demoted rdr_name dflags
+lookup_demoted :: RdrName -> RnM Name
+lookup_demoted rdr_name
   | Just demoted_rdr <- demoteRdrName rdr_name
     -- Maybe it's the name of a *data* constructor
   = do { data_kinds <- xoptM LangExt.DataKinds
+       ; star_is_type <- xoptM LangExt.StarIsType
+       ; let star_info = starInfo star_is_type rdr_name
        ; if data_kinds
             then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
                     ; case mb_demoted_name of
@@ -871,7 +949,7 @@ lookup_demoted rdr_name dflags
                       mb_demoted_name <- discardErrs $
                                          lookupOccRn_maybe demoted_rdr
                     ; let suggestion | isJust mb_demoted_name = suggest_dk
-                                     | otherwise              = star_info
+                                     | otherwise = star_info
                     ; unboundNameX WL_Any rdr_name suggestion } }
 
   | otherwise
@@ -887,17 +965,6 @@ lookup_demoted rdr_name dflags
            , text "instead of"
            , quotes (ppr name) <> dot ]
 
-    star_info
-      | isStar rdr_name || isUniStar rdr_name
-      = if xopt LangExt.TypeInType dflags
-        then text "NB: With TypeInType, you must import" <+>
-             ppr rdr_name <+> text "from Data.Kind"
-        else empty
-
-      | otherwise
-      = empty
-
-
 badVarInType :: RdrName -> RnM Name
 badVarInType rdr_name
   = do { addErr (text "Illegal promoted term variable in a type:"
@@ -1249,7 +1316,7 @@ It is enabled by default and disabled by the flag
 
 Note [Safe Haskell and GHCi]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We DONT do this Safe Haskell as we need to check imports. We can
+We DON'T do this Safe Haskell as we need to check imports. We can
 and should instead check the qualified import but at the moment
 this requires some refactoring so leave as a TODO
 -}
@@ -1437,7 +1504,7 @@ lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
 -- See Note [Fixity signature lookup]
 lookupLocalTcNames ctxt what rdr_name
   = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
-       ; let (errs, names) = splitEithers mb_gres
+       ; let (errs, names) = partitionEithers mb_gres
        ; when (null names) $ addErr (head errs) -- Bleat about one only
        ; return names }
   where
@@ -1558,10 +1625,10 @@ lookupSyntaxNames :: [Name]                         -- Standard names
 lookupSyntaxNames std_names
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
-             return (map (HsVar . noLoc) std_names, emptyFVs)
+             return (map (HsVar noExt . noLoc) std_names, emptyFVs)
         else
           do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
-             ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }
+             ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }
 
 -- Error messages
 
@@ -1573,5 +1640,17 @@ opDeclErr n
 
 badOrigBinding :: RdrName -> SDoc
 badOrigBinding name
-  = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
-        -- The rdrNameOcc is because we don't want to print Prelude.(,)
+  | Just _ <- isBuiltInOcc_maybe occ
+  = text "Illegal binding of built-in syntax:" <+> ppr occ
+    -- Use an OccName here because we don't want to print Prelude.(,)
+  | otherwise
+  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"
+    <+> ppr name
+    -- This can happen when one tries to use a Template Haskell splice to
+    -- define a top-level identifier with an already existing name, e.g.,
+    --
+    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
+    --
+    -- (See Trac #13968.)
+  where
+    occ = rdrNameOcc name
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index c5c75ab671..ae2bdf7a2b 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -21,9 +21,12 @@ module RnExpr (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
                    rnMatchGroup, rnGRHS, makeMiniFixityEnv)
 import HsSyn
+import TcEnv            ( isBrackStage )
 import TcRnMonad
 import Module           ( getModule )
 import RnEnv
@@ -57,6 +60,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Data.Ord
 import Data.Array
+import qualified Data.List.NonEmpty as NE
 
 {-
 ************************************************************************
@@ -92,7 +96,7 @@ finishHsVar (L l name)
  = do { this_mod <- getModule
       ; when (nameIsLocalOrFrom this_mod name) $
         checkThLocalName name
-      ; return (HsVar (L l name), unitFV name) }
+      ; return (HsVar noExt (L l name), unitFV name) }
 
 rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
 rnUnboundVar v
@@ -104,13 +108,13 @@ rnUnboundVar v
                 ; uv <- if startsWithUnderscore occ
                         then return (TrueExprHole occ)
                         else OutOfScope occ <$> getGlobalRdrEnv
-                ; return (HsUnboundVar uv, emptyFVs) }
+                ; return (HsUnboundVar noExt uv, emptyFVs) }
 
         else -- Fail immediately (qualified name)
              do { n <- reportUnboundName v
-                ; return (HsVar (noLoc n), emptyFVs) } }
+                ; return (HsVar noExt (noLoc n), emptyFVs) } }
 
-rnExpr (HsVar (L l v))
+rnExpr (HsVar _ (L l v))
   = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
        ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
        ; case mb_name of {
@@ -118,58 +122,57 @@ rnExpr (HsVar (L l v))
            Just (Left name)
               | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                        -- OverloadedLists works correctly
-              -> rnExpr (ExplicitList placeHolderType Nothing [])
+              -> rnExpr (ExplicitList noExt Nothing [])
 
               | otherwise
               -> finishHsVar (L l name) ;
             Just (Right [s]) ->
-              return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
-                     , unitFV s) ;
+              return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
            Just (Right fs@(_:_:_)) ->
-              return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
+              return ( HsRecFld noExt (Ambiguous noExt (L l v))
                      , mkFVs fs);
            Just (Right [])         -> panic "runExpr/HsVar" } }
 
-rnExpr (HsIPVar v)
-  = return (HsIPVar v, emptyFVs)
+rnExpr (HsIPVar x v)
+  = return (HsIPVar x v, emptyFVs)
 
-rnExpr (HsOverLabel _ v)
+rnExpr (HsOverLabel x _ v)
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if rebindable_on
          then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
-                 ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
-         else return (HsOverLabel Nothing v, emptyFVs) }
+                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
+         else return (HsOverLabel x Nothing v, emptyFVs) }
 
-rnExpr (HsLit lit@(HsString src s))
+rnExpr (HsLit x lit@(HsString src s))
   = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
        ; if opt_OverloadedStrings then
-            rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
+            rnExpr (HsOverLit x (mkHsIsString src s))
          else do {
             ; rnLit lit
-            ; return (HsLit (convertLit lit), emptyFVs) } }
+            ; return (HsLit x (convertLit lit), emptyFVs) } }
 
-rnExpr (HsLit lit)
+rnExpr (HsLit x lit)
   = do { rnLit lit
-       ; return (HsLit (convertLit lit), emptyFVs) }
+       ; return (HsLit x(convertLit lit), emptyFVs) }
 
-rnExpr (HsOverLit lit)
+rnExpr (HsOverLit x lit)
   = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
        ; case mb_neg of
-              Nothing -> return (HsOverLit lit', fvs)
-              Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
+              Nothing -> return (HsOverLit x lit', fvs)
+              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))
                                  , fvs ) }
 
-rnExpr (HsApp fun arg)
+rnExpr (HsApp x fun arg)
   = do { (fun',fvFun) <- rnLExpr fun
        ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
+       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
 
-rnExpr (HsAppType fun arg)
+rnExpr (HsAppType arg fun)
   = do { (fun',fvFun) <- rnLExpr fun
        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
-       ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
+       ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
 
-rnExpr (OpApp e1 op  _ e2)
+rnExpr (OpApp _ e1 op e2)
   = do  { (e1', fv_e1) <- rnLExpr e1
         ; (e2', fv_e2) <- rnLExpr e2
         ; (op', fv_op) <- rnLExpr op
@@ -180,15 +183,15 @@ rnExpr (OpApp e1 op  _ e2)
         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
         -- should prevent bad things happening.
         ; fixity <- case op' of
-              L _ (HsVar (L _ n)) -> lookupFixityRn n
-              L _ (HsRecFld f)    -> lookupFieldFixityRn f
+              L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f
               _ -> return (Fixity NoSourceText minPrecedence InfixL)
                    -- c.f. lookupFixity for unbound
 
         ; final_e <- mkOpAppRn e1' op' fixity e2'
         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
 
-rnExpr (NegApp e _)
+rnExpr (NegApp _ e _)
   = do { (e', fv_e)         <- rnLExpr e
        ; (neg_name, fv_neg) <- lookupSyntaxName negateName
        ; final_e            <- mkNegAppRn e' neg_name
@@ -198,24 +201,24 @@ rnExpr (NegApp e _)
 -- Template Haskell extensions
 -- Don't ifdef-GHCI them because we want to fail gracefully
 -- (not with an rnExpr crash) in a stage-1 compiler.
-rnExpr e@(HsBracket br_body) = rnBracket e br_body
+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
 
-rnExpr (HsSpliceE splice) = rnSpliceExpr splice
+rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
 
 ---------------------------------------------
 --      Sections
 -- See Note [Parsing sections] in Parser.y
-rnExpr (HsPar (L loc (section@(SectionL {}))))
+rnExpr (HsPar x (L loc (section@(SectionL {}))))
   = do  { (section', fvs) <- rnSection section
-        ; return (HsPar (L loc section'), fvs) }
+        ; return (HsPar x (L loc section'), fvs) }
 
-rnExpr (HsPar (L loc (section@(SectionR {}))))
+rnExpr (HsPar x (L loc (section@(SectionR {}))))
   = do  { (section', fvs) <- rnSection section
-        ; return (HsPar (L loc section'), fvs) }
+        ; return (HsPar x (L loc section'), fvs) }
 
-rnExpr (HsPar e)
+rnExpr (HsPar x e)
   = do  { (e', fvs_e) <- rnLExpr e
-        ; return (HsPar e', fvs_e) }
+        ; return (HsPar x e', fvs_e) }
 
 rnExpr expr@(SectionL {})
   = do  { addErr (sectionErr expr); rnSection expr }
@@ -223,71 +226,68 @@ rnExpr expr@(SectionR {})
   = do  { addErr (sectionErr expr); rnSection expr }
 
 ---------------------------------------------
-rnExpr (HsCoreAnn src ann expr)
+rnExpr (HsCoreAnn x src ann expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsCoreAnn src ann expr', fvs_expr) }
+       ; return (HsCoreAnn x src ann expr', fvs_expr) }
 
-rnExpr (HsSCC src lbl expr)
+rnExpr (HsSCC x src lbl expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsSCC src lbl expr', fvs_expr) }
-rnExpr (HsTickPragma src info srcInfo expr)
+       ; return (HsSCC x src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma x src info srcInfo expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
+       ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
 
-rnExpr (HsLam matches)
+rnExpr (HsLam x matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
-       ; return (HsLam matches', fvMatch) }
+       ; return (HsLam x matches', fvMatch) }
 
-rnExpr (HsLamCase matches)
+rnExpr (HsLamCase x matches)
   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
-       ; return (HsLamCase matches', fvs_ms) }
+       ; return (HsLamCase x matches', fvs_ms) }
 
-rnExpr (HsCase expr matches)
+rnExpr (HsCase x expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
-       ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
 
-rnExpr (HsLet (L l binds) expr)
+rnExpr (HsLet x (L l binds) expr)
   = rnLocalBindsAndThen binds $ \binds' _ -> do
       { (expr',fvExpr) <- rnLExpr expr
-      ; return (HsLet (L l binds') expr', fvExpr) }
+      ; return (HsLet x (L l binds') expr', fvExpr) }
 
-rnExpr (HsDo do_or_lc (L l stmts) _)
+rnExpr (HsDo x do_or_lc (L l stmts))
   = do  { ((stmts', _), fvs) <-
            rnStmtsWithPostProcessing do_or_lc rnLExpr
              postProcessStmtsForApplicativeDo stmts
              (\ _ -> return ((), emptyFVs))
-        ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
+        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
 
-rnExpr (ExplicitList _ _  exps)
+rnExpr (ExplicitList x _  exps)
   = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
         ; (exps', fvs) <- rnExprs exps
         ; if opt_OverloadedLists
            then do {
             ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
-            ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
+            ; return (ExplicitList x (Just from_list_n_name) exps'
                      , fvs `plusFV` fvs') }
            else
-            return  (ExplicitList placeHolderType Nothing exps', fvs) }
-
-rnExpr (ExplicitPArr _ exps)
-  = do { (exps', fvs) <- rnExprs exps
-       ; return  (ExplicitPArr placeHolderType exps', fvs) }
+            return  (ExplicitList x Nothing exps', fvs) }
 
-rnExpr (ExplicitTuple tup_args boxity)
+rnExpr (ExplicitTuple x tup_args boxity)
   = do { checkTupleSection tup_args
        ; checkTupSize (length tup_args)
        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
-       ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
   where
-    rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
-                                    ; return (L l (Present e'), fvs) }
-    rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
+    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
+                                      ; return (L l (Present x e'), fvs) }
+    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
                                         , emptyFVs)
+    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
 
-rnExpr (ExplicitSum alt arity expr _)
+rnExpr (ExplicitSum x alt arity expr)
   = do { (expr', fvs) <- rnLExpr expr
-       ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }
+       ; return (ExplicitSum x alt arity expr', fvs) }
 
 rnExpr (RecordCon { rcon_con_name = con_id
                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
@@ -295,53 +295,49 @@ rnExpr (RecordCon { rcon_con_name = con_id
        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
        ; (flds', fvss) <- mapAndUnzipM rn_field flds
        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
-       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
-                           , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+       ; return (RecordCon { rcon_ext = noExt
+                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }
                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
   where
-    mk_hs_var l n = HsVar (L l n)
+    mk_hs_var l n = HsVar noExt (L l n)
     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
                             ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 
 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
   = do  { (expr', fvExpr) <- rnLExpr expr
         ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
-        ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
-                            , rupd_cons    = PlaceHolder, rupd_in_tys = PlaceHolder
-                            , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
+        ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
+                            , rupd_flds = rbinds' }
                  , fvExpr `plusFV` fvRbinds) }
 
-rnExpr (ExprWithTySig expr pty)
+rnExpr (ExprWithTySig pty expr)
   = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                              rnLExpr expr
-        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
+        ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
 
-rnExpr (HsIf _ p b1 b2)
+rnExpr (HsIf x _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
        ; (b1', fvB1) <- rnLExpr b1
        ; (b2', fvB2) <- rnLExpr b2
        ; (mb_ite, fvITE) <- lookupIfThenElse
-       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
-rnExpr (HsMultiIf _ty alts)
+rnExpr (HsMultiIf x alts)
   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
        -- ; return (HsMultiIf ty alts', fvs) }
-       ; return (HsMultiIf placeHolderType alts', fvs) }
+       ; return (HsMultiIf x alts', fvs) }
 
-rnExpr (ArithSeq _ _ seq)
+rnExpr (ArithSeq x _ seq)
   = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
        ; (new_seq, fvs) <- rnArithSeq seq
        ; if opt_OverloadedLists
            then do {
             ; (from_list_name, fvs') <- lookupSyntaxName fromListName
-            ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
+            ; return (ArithSeq x (Just from_list_name) new_seq
+                     , fvs `plusFV` fvs') }
            else
-            return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
-
-rnExpr (PArrSeq _ seq)
-  = do { (new_seq, fvs) <- rnArithSeq seq
-       ; return (PArrSeq noPostTcExpr new_seq, fvs) }
+            return (ArithSeq x Nothing new_seq, fvs) }
 
 {-
 These three are pattern syntax appearing in expressions.
@@ -349,7 +345,7 @@ Since all the symbols are reservedops we can simply reject them.
 We return a (bogus) EWildPat in each case.
 -}
 
-rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
+rnExpr (EWildPat _)  = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
 rnExpr e@(EAsPat {})
   = do { opt_TypeApplications <- xoptM LangExt.TypeApplications
        ; let msg | opt_TypeApplications
@@ -368,12 +364,22 @@ rnExpr e@(ELazyPat {}) = patSynErr e empty
 *                                                                      *
 ************************************************************************
 
-For the static form we check that the free variables are all top-level
-value bindings. This is done by checking that the name is external or
-wired-in. See the Notes about the NameSorts in Name.hs.
+For the static form we check that it is not used in splices.
+We also collect the free variables of the term which come from
+this module. See Note [Grand plan for static forms] in StaticPtrTable.
 -}
 
 rnExpr e@(HsStatic _ expr) = do
+    -- Normally, you wouldn't be able to construct a static expression without
+    -- first enabling -XStaticPointers in the first place, since that extension
+    -- is what makes the parser treat `static` as a keyword. But this is not a
+    -- sufficient safeguard, as one can construct static expressions by another
+    -- mechanism: Template Haskell (see #14204). To ensure that GHC is
+    -- absolutely prepared to cope with static forms, we check for
+    -- -XStaticPointers here as well.
+    unlessXOptM LangExt.StaticPointers $
+      addErr $ hang (text "Illegal static expression:" <+> ppr e)
+                  2 (text "Use StaticPointers to enable this extension")
     (expr',fvExpr) <- rnLExpr expr
     stage <- getStage
     case stage of
@@ -394,11 +400,11 @@ rnExpr e@(HsStatic _ expr) = do
 ************************************************************************
 -}
 
-rnExpr (HsProc pat body)
+rnExpr (HsProc x pat body)
   = newArrowScope $
     rnPat ProcExpr pat $ \ pat' -> do
       { (body',fvBody) <- rnCmdTop body
-      ; return (HsProc pat' body', fvBody) }
+      ; return (HsProc x pat' body', fvBody) }
 
 -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
 rnExpr e@(HsArrApp {})  = arrowFail e
@@ -407,8 +413,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
         -- HsWrap
 
-hsHoleExpr :: HsExpr id
-hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
 
 arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
 arrowFail e
@@ -421,17 +427,17 @@ arrowFail e
 ----------------------
 -- See Note [Parsing sections] in Parser.y
 rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnSection section@(SectionR op expr)
+rnSection section@(SectionR x op expr)
   = do  { (op', fvs_op)     <- rnLExpr op
         ; (expr', fvs_expr) <- rnLExpr expr
         ; checkSectionPrec InfixR section op' expr'
-        ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
+        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
 
-rnSection section@(SectionL expr op)
+rnSection section@(SectionL x expr op)
   = do  { (expr', fvs_expr) <- rnLExpr expr
         ; (op', fvs_op)     <- rnLExpr op
         ; checkSectionPrec InfixL section op' expr'
-        ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
 
 rnSection other = pprPanic "rnSection" (ppr other)
 
@@ -453,26 +459,26 @@ rnCmdArgs (arg:args)
 rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
 rnCmdTop = wrapLocFstM rnCmdTop'
  where
-  rnCmdTop' (HsCmdTop cmd _ _ _)
+  rnCmdTop' (HsCmdTop _ cmd)
    = do { (cmd', fvCmd) <- rnLCmd cmd
         ; let cmd_names = [arrAName, composeAName, firstAName] ++
                           nameSetElemsStable (methodNamesCmd (unLoc cmd'))
         -- Generate the rebindable syntax for the monad
         ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
 
-        ; return (HsCmdTop cmd' placeHolderType placeHolderType
-                  (cmd_names `zip` cmd_names'),
+        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
                   fvCmd `plusFV` cmd_fvs) }
+  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
 
 rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
 rnLCmd = wrapLocFstM rnCmd
 
 rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
 
-rnCmd (HsCmdArrApp arrow arg _ ho rtl)
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
   = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
        ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
+       ; return (HsCmdArrApp x arrow' arg' ho rtl,
                  fvArrow `plusFV` fvArg) }
   where
     select_arrow_scope tc = case ho of
@@ -485,9 +491,9 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
         -- inside 'arrow'.  In the higher-order case (-<<), they are.
 
 -- infix form
-rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
-       ; let L _ (HsVar (L _ op_name)) = op'
+       ; let L _ (HsVar _ (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
        ; (arg2',fv_arg2) <- rnCmdTop arg2
         -- Deal with fixity
@@ -495,47 +501,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
 
-rnCmd (HsCmdArrForm op f fixity cmds)
+rnCmd (HsCmdArrForm x op f fixity cmds)
   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
        ; (cmds',fvCmds) <- rnCmdArgs cmds
-       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
+       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }
 
-rnCmd (HsCmdApp fun arg)
+rnCmd (HsCmdApp x fun arg)
   = do { (fun',fvFun) <- rnLCmd  fun
        ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
+       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
 
-rnCmd (HsCmdLam matches)
+rnCmd (HsCmdLam x matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
-       ; return (HsCmdLam matches', fvMatch) }
+       ; return (HsCmdLam x matches', fvMatch) }
 
-rnCmd (HsCmdPar e)
+rnCmd (HsCmdPar x e)
   = do  { (e', fvs_e) <- rnLCmd e
-        ; return (HsCmdPar e', fvs_e) }
+        ; return (HsCmdPar x e', fvs_e) }
 
-rnCmd (HsCmdCase expr matches)
+rnCmd (HsCmdCase x expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
-       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
 
-rnCmd (HsCmdIf _ p b1 b2)
+rnCmd (HsCmdIf x _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
        ; (b1', fvB1) <- rnLCmd b1
        ; (b2', fvB2) <- rnLCmd b2
        ; (mb_ite, fvITE) <- lookupIfThenElse
-       ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
 
-rnCmd (HsCmdLet (L l binds) cmd)
+rnCmd (HsCmdLet x (L l binds) cmd)
   = rnLocalBindsAndThen binds $ \ binds' _ -> do
       { (cmd',fvExpr) <- rnLCmd cmd
-      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
+      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }
 
-rnCmd (HsCmdDo (L l stmts) _)
+rnCmd (HsCmdDo x (L l stmts))
   = do  { ((stmts', _), fvs) <-
             rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
-        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
+        ; return ( HsCmdDo x (L l stmts'), fvs ) }
 
 rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)
 
 ---------------------------------------------------
 type CmdNeeds = FreeVars        -- Only inhabitants are
@@ -547,26 +554,28 @@ methodNamesLCmd = methodNamesCmd . unLoc
 
 methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
 
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
   = emptyFVs
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
   = unitFV appAName
 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
 
-methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
+methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
 
-methodNamesCmd (HsCmdIf _ _ c1 c2)
+methodNamesCmd (HsCmdIf _ _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
-methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
-methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
-methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
+methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c
+methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match
 
-methodNamesCmd (HsCmdCase _ matches)
+methodNamesCmd (HsCmdCase _ _ matches)
   = methodNamesMatch matches `addOneFV` choiceAName
 
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
 --methodNamesCmd _ = emptyFVs
    -- Other forms can't occur in commands, but it's not convenient
    -- to error here so we just do what's convenient.
@@ -577,17 +586,21 @@ methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
 methodNamesMatch (MG { mg_alts = L _ ms })
   = plusFVs (map do_one ms)
  where
-    do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
+    do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
 
 -------------------------------------------------
 -- gaw 2004
 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
 
 -------------------------------------------------
 
 methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
-methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
 
 ---------------------------------------------------
 methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
@@ -598,17 +611,18 @@ methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
 methodNamesLStmt = methodNamesStmt . unLoc
 
 methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
-methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd
+methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd
 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
   methodNamesStmts stmts `addOneFV` loopAName
-methodNamesStmt (LetStmt {})                     = emptyFVs
-methodNamesStmt (ParStmt {})                     = emptyFVs
-methodNamesStmt (TransStmt {})                   = emptyFVs
-methodNamesStmt ApplicativeStmt{}            = emptyFVs
+methodNamesStmt (LetStmt {})                   = emptyFVs
+methodNamesStmt (ParStmt {})                   = emptyFVs
+methodNamesStmt (TransStmt {})                 = emptyFVs
+methodNamesStmt ApplicativeStmt{}              = emptyFVs
    -- ParStmt and TransStmt can't occur in commands, but it's not
    -- convenient to error here so we just do what's convenient
+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
 
 {-
 ************************************************************************
@@ -718,8 +732,12 @@ postProcessStmtsForApplicativeDo ctxt stmts
          ado_is_on <- xoptM LangExt.ApplicativeDo
        ; let is_do_expr | DoExpr <- ctxt = True
                         | otherwise = False
-       ; if ado_is_on && is_do_expr
-            then rearrangeForApplicativeDo ctxt stmts
+       -- don't apply the transformation inside TH brackets, because
+       -- DsMeta does not handle ApplicativeDo.
+       ; in_th_bracket <- isBrackStage <$> getStage
+       ; if ado_is_on && is_do_expr && not in_th_bracket
+            then do { traceRn "ppsfa" (ppr stmts)
+                    ; rearrangeForApplicativeDo ctxt stmts }
             else noPostProcessStmts ctxt stmts }
 
 -- | strip the FreeVars annotations from statements
@@ -806,28 +824,36 @@ rnStmt :: Outputable (body GhcPs)
 -- Variables bound by the Stmt, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
 
-rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
+rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
-        ; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName
-        ; (thing,  fvs3)   <- thing_inside []
-        ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
-                  fv_expr `plusFV` fvs1 `plusFV` fvs3) }
-
-rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
+        ; (ret_op, fvs1) <- if isMonadCompContext ctxt
+                            then lookupStmtName ctxt returnMName
+                            else return (noSyntaxExpr, emptyFVs)
+                            -- The 'return' in a LastStmt is used only
+                            -- for MonadComp; and we don't want to report
+                            -- "non in scope: return" in other cases
+                            -- Trac #15607
+
+        ; (thing,  fvs3) <- thing_inside []
+        ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
         ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
-        ; (guard_op, fvs2) <- if isListCompExpr ctxt
+
+        ; (guard_op, fvs2) <- if isComprehensionContext ctxt
                               then lookupStmtName ctxt guardMName
                               else return (noSyntaxExpr, emptyFVs)
-                              -- Only list/parr/monad comprehensions use 'guard'
+                              -- Only list/monad comprehensions use 'guard'
                               -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
                               -- Here "gd" is a guard
+
         ; (thing, fvs3)    <- thing_inside []
-        ; return (([(L loc (BodyStmt body'
-                     then_op guard_op placeHolderType), fv_expr)], thing),
-                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+        ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 
-rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
@@ -837,29 +863,33 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
                 -- If the pattern is irrefutable (e.g.: wildcard, tuple,
                 -- ~pat, etc.) we should not need to fail.
                 | isIrrefutableHsPat pat
-                                    = return (noSyntaxExpr, emptyFVs)
+                = return (noSyntaxExpr, emptyFVs)
+
                 -- For non-monadic contexts (e.g. guard patterns, list
                 -- comprehensions, etc.) we should not need to fail.
                 -- See Note [Failing pattern matches in Stmts]
                 | not (isMonadFailStmtContext ctxt)
-                                    = return (noSyntaxExpr, emptyFVs)
+                = return (noSyntaxExpr, emptyFVs)
+
                 | xMonadFailEnabled = lookupSyntaxName failMName
                 | otherwise         = lookupSyntaxName failMName_preMFP
+
         ; (fail_op, fvs2) <- getFailFunction
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
-        ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
+        ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
                      , fv_expr )]
                   , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
         -- but it does not matter because the names are unique
 
-rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
+rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
   = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
-        ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) }  }
+        ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
+                 , fvs) }  }
 
 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
   = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
@@ -891,12 +921,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
                  , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 
-rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
+rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
   = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
         ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
         ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
-        ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
+        ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)
                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 
 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -929,15 +959,18 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
              -- See Note [TransStmt binder map] in HsExpr
 
        ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
-       ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+       ; return (([(L loc (TransStmt { trS_ext = noExt
+                                    , trS_stmts = stmts', trS_bndrs = bndr_map
                                     , trS_by = by', trS_using = using', trS_form = form
                                     , trS_ret = return_op, trS_bind = bind_op
-                                    , trS_bind_arg_ty = PlaceHolder
                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
 
 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
   panic "rnStmt: ApplicativeStmt"
 
+rnStmt _ _ (L _ XStmtLR{}) _ =
+  panic "rnStmt: XStmtLR"
+
 rnParallelStmts :: forall thing. HsStmtContext Name
                 -> SyntaxExpr GhcRn
                 -> [ParStmtBlock GhcPs GhcPs]
@@ -957,7 +990,7 @@ rnParallelStmts ctxt return_op segs thing_inside
            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
            ; return (([], thing), fvs) }
 
-    rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
+    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
                     <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
                        setLocalRdrEnv env       $ do
@@ -965,12 +998,13 @@ rnParallelStmts ctxt return_op segs thing_inside
                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
                        ; return ((used_bndrs, segs', thing), fvs) }
 
-           ; let seg' = ParStmtBlock stmts' used_bndrs return_op
+           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
            ; return ((seg':segs', thing), fvs) }
+    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
 
     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
     dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
-                    <+> quotes (ppr (head vs)))
+                    <+> quotes (ppr (NE.head vs)))
 
 lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
 -- Like lookupSyntaxName, but respects contexts
@@ -986,20 +1020,19 @@ lookupStmtNamePoly ctxt name
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if rebindable_on
          then do { fm <- lookupOccRn (nameRdrName name)
-                 ; return (HsVar (noLoc fm), unitFV fm) }
+                 ; return (HsVar noExt (noLoc fm), unitFV fm) }
          else not_rebindable }
   | otherwise
   = not_rebindable
   where
-    not_rebindable = return (HsVar (noLoc name), emptyFVs)
+    not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
 
 -- | Is this a context where we respect RebindableSyntax?
--- but ListComp/PArrComp are never rebindable
+-- but ListComp are never rebindable
 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
 rebindableContext :: HsStmtContext Name -> Bool
 rebindableContext ctxt = case ctxt of
   ListComp        -> False
-  PArrComp        -> False
   ArrowExpr       -> False
   PatGuard {}     -> False
 
@@ -1081,10 +1114,10 @@ rnRecStmtsAndThen rnBody s cont
 collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
 collectRecStmtsFixities l =
     foldr (\ s -> \acc -> case s of
-            (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
-                foldr (\ sig -> \ acc -> case sig of
-                                           (L loc (FixSig s)) -> (L loc s) : acc
-                                           _ -> acc) acc sigs
+            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
+              foldr (\ sig -> \ acc -> case sig of
+                                         (L loc (FixSig _ s)) -> (L loc s) : acc
+                                         _ -> acc) acc sigs
             _ -> acc) [] l
 
 -- left-hand sides
@@ -1096,25 +1129,24 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
                    -- so we don't bother to compute it accurately in the other cases
                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
 
-rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
-  = return [(L loc (BodyStmt body a b c), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
+  = return [(L loc (BodyStmt noExt body a b), emptyFVs)]
 
-rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
-  = return [(L loc (LastStmt body noret a), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
+  = return [(L loc (LastStmt noExt body noret a), emptyFVs)]
 
-rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
   = do
       -- should the ctxt be MDo instead?
       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
-      return [(L loc (BindStmt pat' body a b t),
-               fv_pat)]
+      return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
 
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
   = failWith (badIpBinds (text "an mdo expression") binds)
 
-rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
-         return [(L loc (LetStmt (L l (HsValBinds binds'))),
+         return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
                  -- Warning: this is bogus; see function invariant
                  emptyFVs
                  )]
@@ -1132,8 +1164,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
   = pprPanic "rn_rec_stmt" (ppr stmt)
 
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
+  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
+rn_rec_stmt_lhs _ (L _ (XStmtLR _))
+  = panic "rn_rec_stmt XStmtLR"
 
 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
                  -> [LStmt GhcPs body]
@@ -1158,19 +1194,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) =>
         -- Rename a Stmt that is inside a RecStmt (or mdo)
         -- Assumes all binders are already in scope
         -- Turns each stmt into a singleton Stmt
-rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
   = do  { (body', fv_expr) <- rnBody body
         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
-                   L loc (LastStmt body' noret ret_op))] }
+                   L loc (LastStmt noExt body' noret ret_op))] }
 
-rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
+rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
   = do { (body', fvs) <- rnBody body
        ; (then_op, fvs1) <- lookupSyntaxName thenMName
        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
-                 L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
+                 L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
 
-rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 
@@ -1182,17 +1218,17 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
+                  L loc (BindStmt noExt pat' body' bind_op fail_op))] }
 
-rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
 
-rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
+rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
   = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
            -- fixities and unused are handled above in rnRecStmtsAndThen
        ; let fvs = allUses du_binds
        ; return [(duDefs du_binds, fvs, emptyNameSet,
-                 L loc (LetStmt (L l (HsValBinds binds'))))] }
+                 L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }
 
 -- no RecStmt case because they get flattened above when doing the LHSes
 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
@@ -1204,12 +1240,18 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
 
-rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)
+  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
 
 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
   = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
 
+rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
+  = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
+
 rn_rec_stmts :: Outputable (body GhcPs) =>
                 (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
              -> [Name]
@@ -1512,6 +1554,7 @@ rearrangeForApplicativeDo ctxt stmts0 = do
   optimal_ado <- goptM Opt_OptimalApplicativeDo
   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
                 | otherwise = mkStmtTreeHeuristic stmts
+  traceRn "rearrangeForADo" (ppr stmt_tree)
   return_name <- lookupSyntaxName' returnMName
   pure_name   <- lookupSyntaxName' pureAName
   let monad_names = MonadNames { return_name = return_name
@@ -1529,6 +1572,13 @@ data StmtTree a
   | StmtTreeBind (StmtTree a) (StmtTree a)
   | StmtTreeApplicative [StmtTree a]
 
+instance Outputable a => Outputable (StmtTree a) where
+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
+                                            2 (sep [ppr x, ppr y]))
+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
+                                            2 (vcat (map ppr xs)))
+
 flattenStmtTree :: StmtTree a -> [a]
 flattenStmtTree t = go t []
  where
@@ -1633,11 +1683,16 @@ stmtTreeToStmts
 -- In the spec, but we do it here rather than in the desugarer,
 -- because we need the typechecker to typecheck the <$> form rather than
 -- the bind form, which would give rise to a Monad constraint.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
                 tail _tail_fvs
   | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
   -- See Note [ApplicativeDo and strict patterns]
-  = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
+  = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+                tail _tail_fvs
+  | (False,tail') <- needJoin monad_names tail
+  = mkApplicativeStmt ctxt
+      [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
   return (s : tail, emptyNameSet)
@@ -1655,8 +1710,10 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
    (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
    return (stmts, unionNameSets (fvs:fvss))
  where
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
-     return (ApplicativeArgOne pat exp, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
+     = return (ApplicativeArgOne noExt pat exp False, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
+     return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
    stmtTreeArg ctxt tail_fvs tree = do
      let stmts = flattenStmtTree tree
          pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1671,8 +1728,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
              return (unLoc tup, emptyNameSet)
            | otherwise -> do
              (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
-             return (HsApp (noLoc ret) tup, fvs)
-     return ( ApplicativeArgMany stmts' mb_ret pat
+             return (HsApp noExt (noLoc ret) tup, fvs)
+     return ( ApplicativeArgMany noExt stmts' mb_ret pat
             , fvs1 `plusFV` fvs2)
 
 
@@ -1726,7 +1783,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
 
     isStrictPatternBind :: ExprLStmt GhcRn -> Bool
-    isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat
+    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
     isStrictPatternBind _ = False
 
 {-
@@ -1757,24 +1814,23 @@ can do with the rest of the statements in the same "do" expression.
 isStrictPattern :: LPat id -> Bool
 isStrictPattern (L _ pat) =
   case pat of
-    WildPat{} -> False
-    VarPat{}  -> False
-    LazyPat{} -> False
-    AsPat _ p -> isStrictPattern p
-    ParPat p  -> isStrictPattern p
-    ViewPat _ p _ -> isStrictPattern p
-    SigPatIn p _ -> isStrictPattern p
-    SigPatOut p _ -> isStrictPattern p
-    BangPat{} -> True
-    TuplePat{} -> True
-    SumPat{} -> True
-    PArrPat{} -> True
-    ConPatIn{} -> True
-    ConPatOut{} -> True
-    LitPat{} -> True
-    NPat{} -> True
-    NPlusKPat{} -> True
-    SplicePat{} -> True
+    WildPat{}       -> False
+    VarPat{}        -> False
+    LazyPat{}       -> False
+    AsPat _ _ p     -> isStrictPattern p
+    ParPat _ p      -> isStrictPattern p
+    ViewPat _ _ p   -> isStrictPattern p
+    SigPat _ p      -> isStrictPattern p
+    BangPat{}       -> True
+    ListPat{}       -> True
+    TuplePat{}      -> True
+    SumPat{}        -> True
+    ConPatIn{}      -> True
+    ConPatOut{}     -> True
+    LitPat{}        -> True
+    NPat{}          -> True
+    NPlusKPat{}     -> True
+    SplicePat{}     -> True
     _otherwise -> panic "isStrictPattern"
 
 isLetStmt :: LStmt a b -> Bool
@@ -1810,10 +1866,13 @@ slurpIndependentStmts
 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
  where
   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
-  -- in this group, then add it to the group.
-  go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
-    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
-    = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
+  -- in this group, then add it to the group. We have to be careful about
+  -- strict patterns though; splitSegments expects that if we return Just
+  -- then we have actually done some splitting. Otherwise it will go into
+  -- an infinite loop (#14163).
+  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
+    = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
          bndrs' rest
     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
@@ -1821,9 +1880,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
   -- grouping more BindStmts.
   -- TODO: perhaps we shouldn't do this if there are any strict bindings,
   -- because we might be moving evaluation earlier.
-  go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
+  go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
     | isEmptyNameSet (bndrs `intersectNameSet` fvs)
-    = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
+    = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
   go _ []  _ _ = Nothing
   go _ [_] _ _ = Nothing
   go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
@@ -1843,7 +1902,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
 -- typechecker and the desugarer (I tried it that way first!).
 mkApplicativeStmt
   :: HsStmtContext Name
-  -> [ApplicativeArg GhcRn GhcRn]         -- ^ The args
+  -> [ApplicativeArg GhcRn]             -- ^ The args
   -> Bool                               -- ^ True <=> need a join
   -> [ExprLStmt GhcRn]        -- ^ The body statements
   -> RnM ([ExprLStmt GhcRn], FreeVars)
@@ -1856,10 +1915,9 @@ mkApplicativeStmt ctxt args need_join body_stmts
                 ; return (Just join_op, fvs) }
            else
              return (Nothing, emptyNameSet)
-       ; let applicative_stmt = noLoc $ ApplicativeStmt
+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExt
                (zip (fmap_op : repeat ap_op) args)
                mb_join
-               placeHolderType
        ; return ( applicative_stmt : body_stmts
                 , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 
@@ -1869,9 +1927,9 @@ needJoin :: MonadNames
          -> [ExprLStmt GhcRn]
          -> (Bool, [ExprLStmt GhcRn])
 needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg
-needJoin monad_names  [L loc (LastStmt e _ t)]
+needJoin monad_names  [L loc (LastStmt _ e _ t)]
  | Just arg <- isReturnApp monad_names e =
-       (False, [L loc (LastStmt arg True t)])
+       (False, [L loc (LastStmt noExt arg True t)])
 needJoin _monad_names stmts = (True, stmts)
 
 -- | @Just e@, if the expression is @return e@ or @return $ e@,
@@ -1879,15 +1937,15 @@ needJoin _monad_names stmts = (True, stmts)
 isReturnApp :: MonadNames
             -> LHsExpr GhcRn
             -> Maybe (LHsExpr GhcRn)
-isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
 isReturnApp monad_names (L _ e) = case e of
-  OpApp l op _ r | is_return l, is_dollar op -> Just r
-  HsApp f arg    | is_return f               -> Just arg
+  OpApp _ l op r | is_return l, is_dollar op -> Just r
+  HsApp _ f arg  | is_return f               -> Just arg
   _otherwise -> Nothing
  where
-  is_var f (L _ (HsPar e)) = is_var f e
-  is_var f (L _ (HsAppType e _)) = is_var f e
-  is_var f (L _ (HsVar (L _ r))) = f r
+  is_var f (L _ (HsPar _ e)) = is_var f e
+  is_var f (L _ (HsAppType _ e)) = is_var f e
+  is_var f (L _ (HsVar _ (L _ r))) = f r
        -- TODO: I don't know how to get this right for rebindable syntax
   is_var _ _ = False
 
@@ -1925,7 +1983,6 @@ checkLastStmt ctxt lstmt@(L loc stmt)
   = case ctxt of
       ListComp  -> check_comp
       MonadComp -> check_comp
-      PArrComp  -> check_comp
       ArrowExpr -> check_do
       DoExpr    -> check_do
       MDoExpr   -> check_do
@@ -1933,7 +1990,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
   where
     check_do    -- Expect BodyStmt, and change it to LastStmt
       = case stmt of
-          BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
+          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
           LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
                                              -- LastStmt directly (unlike the parser)
           _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
@@ -1970,16 +2027,17 @@ pprStmtCat (LetStmt {})       = text "let"
 pprStmtCat (RecStmt {})       = text "rec"
 pprStmtCat (ParStmt {})       = text "parallel"
 pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"
 
 ------------
 emptyInvalid :: Validity  -- Payload is the empty document
 emptyInvalid = NotValid Outputable.empty
 
-okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+okStmt, okDoStmt, okCompStmt, okParStmt
    :: DynFlags -> HsStmtContext Name
    -> Stmt GhcPs (Located (body GhcPs)) -> Validity
 -- Return Nothing if OK, (Just extra) if not ok
--- The "extra" is an SDoc that is appended to an generic error message
+-- The "extra" is an SDoc that is appended to a generic error message
 
 okStmt dflags ctxt stmt
   = case ctxt of
@@ -1991,7 +2049,6 @@ okStmt dflags ctxt stmt
       GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt
       ListComp           -> okCompStmt dflags ctxt stmt
       MonadComp          -> okCompStmt dflags ctxt stmt
-      PArrComp           -> okPArrStmt dflags ctxt stmt
       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
 
 -------------
@@ -2006,8 +2063,8 @@ okPatGuardStmt stmt
 -------------
 okParStmt dflags ctxt stmt
   = case stmt of
-      LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
-      _                            -> okStmt dflags ctxt stmt
+      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid
+      _                              -> okStmt dflags ctxt stmt
 
 ----------------
 okDoStmt dflags ctxt stmt
@@ -2036,20 +2093,7 @@ okCompStmt dflags _ stmt
        RecStmt {}  -> emptyInvalid
        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
        ApplicativeStmt {} -> emptyInvalid
-
-----------------
-okPArrStmt dflags _ stmt
-  = case stmt of
-       BindStmt {} -> IsValid
-       LetStmt {}  -> IsValid
-       BodyStmt {} -> IsValid
-       ParStmt {}
-         | LangExt.ParallelListComp `xopt` dflags -> IsValid
-         | otherwise -> NotValid (text "Use ParallelListComp")
-       TransStmt {} -> emptyInvalid
-       RecStmt {}   -> emptyInvalid
-       LastStmt {}  -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
-       ApplicativeStmt {} -> emptyInvalid
+       XStmtLR{} -> panic "okCompStmt"
 
 ---------
 checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
@@ -2069,7 +2113,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
                                 nest 4 (ppr e)] $$
                                   explanation)
-                 ; return (EWildPat, emptyFVs) }
+                 ; return (EWildPat noExt, emptyFVs) }
 
 badIpBinds :: Outputable a => SDoc -> a -> SDoc
 badIpBinds what binds
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
index 0bd08574a0..f1bfb380a5 100644
--- a/compiler/rename/RnFixity.hs
+++ b/compiler/rename/RnFixity.hs
@@ -9,6 +9,8 @@ module RnFixity ( MiniFixityEnv,
   lookupFixityRn, lookupFixityRn_help,
   lookupFieldFixityRn, lookupTyFixityRn ) where
 
+import GhcPrelude
+
 import LoadIface
 import HsSyn
 import RdrName
@@ -177,9 +179,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
 -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
 -- multiple possible selectors with different fixities, generate an error.
 lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (Unambiguous (L _ rdr) n)
+lookupFieldFixityRn (Unambiguous n (L _ rdr))
   = lookupFixityRn' n (rdrNameOcc rdr)
-lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
+lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr
   where
     get_ambiguous_fixity :: RdrName -> RnM Fixity
     get_ambiguous_fixity rdr_name = do
@@ -207,3 +209,4 @@ lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
 
     format_ambig (elt, fix) = hang (ppr fix)
                                  2 (pprNameProvenance elt)
+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
index 9e53f49320..ac2589df4e 100644
--- a/compiler/rename/RnHsDoc.hs
+++ b/compiler/rename/RnHsDoc.hs
@@ -1,6 +1,8 @@
 
 module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
 
+import GhcPrelude
+
 import TcRnTypes
 import HsSyn
 import SrcLoc
@@ -19,5 +21,5 @@ rnLHsDoc (L pos doc) = do
   return (L pos doc')
 
 rnHsDoc :: HsDocString -> RnM HsDocString
-rnHsDoc (HsDocString s) = return (HsDocString s)
+rnHsDoc = pure
 
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 6197bc7480..8ded9c27db 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -20,11 +20,17 @@ module RnNames (
         mkChildEnv,
         findChildren,
         dodgyMsg,
-        dodgyMsgInsert
+        dodgyMsgInsert,
+        findImportUsage,
+        getMinimalImports,
+        printMinimalImports,
+        ImportDeclUsage
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import HsSyn
 import TcEnv
@@ -132,7 +138,7 @@ So there is an interesting design question in regards to transitive trust
 checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
 of modules and packages, some packages it requires to be trusted as its using
 -XTrustworthy modules from them. Now if I have a module A that doesn't use safe
-haskell at all and simply imports B, should A inherit all the the trust
+haskell at all and simply imports B, should A inherit all the trust
 requirements from B? Should A now also require that a package p is trusted since
 B required it?
 
@@ -175,16 +181,71 @@ rnImports imports = do
     return (decls, rdr_env, imp_avails, hpc_usage)
 
   where
+    -- See Note [Combining ImportAvails]
     combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
             -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
-    combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
-
-    plus (decl,  gbl_env1, imp_avails1,hpc_usage1)
-         (decls, gbl_env2, imp_avails2,hpc_usage2)
+    combine ss =
+      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
+            plus
+            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
+            ss
+      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
+            hpc_usage)
+
+    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)
+         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
       = ( decl:decls,
           gbl_env1 `plusGlobalRdrEnv` gbl_env2,
-          imp_avails1 `plusImportAvails` imp_avails2,
-          hpc_usage1 || hpc_usage2 )
+          imp_avails1' `plusImportAvails` imp_avails2,
+          hpc_usage1 || hpc_usage2,
+          extendModuleSetList finsts_set new_finsts )
+      where
+      imp_avails1' = imp_avails1 { imp_finsts = [] }
+      new_finsts = imp_finsts imp_avails1
+
+{-
+Note [Combining ImportAvails]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+imp_finsts in ImportAvails is a list of family instance modules
+transitively depended on by an import. imp_finsts for a currently
+compiled module is a union of all the imp_finsts of imports.
+Computing the union of two lists of size N is O(N^2) and if we
+do it to M imports we end up with O(M*N^2). That can get very
+expensive for bigger module hierarchies.
+
+Union can be optimized to O(N log N) if we use a Set.
+imp_finsts is converted back and forth between dep_finsts, so
+changing a type of imp_finsts means either paying for the conversions
+or changing the type of dep_finsts as well.
+
+I've measured that the conversions would cost 20% of allocations on my
+test case, so that can be ruled out.
+
+Changing the type of dep_finsts forces checkFamInsts to
+get the module lists in non-deterministic order. If we wanted to restore
+the deterministic order, we'd have to sort there, which is an additional
+cost. As far as I can tell, using a non-deterministic order is fine there,
+but that's a brittle nonlocal property which I'd like to avoid.
+
+Additionally, dep_finsts is read from an interface file, so its "natural"
+type is a list. Which makes it a natural type for imp_finsts.
+
+Since rnImports.combine is really the only place that would benefit from
+it being a Set, it makes sense to optimize the hot loop in rnImports.combine
+without changing the representation.
+
+So here's what we do: instead of naively merging ImportAvails with
+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts
+and compute the union on the side using Sets. When we're done, we can
+convert it back to a list. One nice side effect of this approach is that
+if there's a lot of overlap in the imp_finsts of imports, the
+Set doesn't really need to grow and we don't need to allocate.
+
+Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in
+23s before, and 11s after.
+-}
+
+
 
 -- | Given a located import declaration @decl@ from @this_mod@,
 -- calculate the following pieces of information:
@@ -204,7 +265,9 @@ rnImports imports = do
 rnImportDecl  :: Module -> LImportDecl GhcPs
              -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
 rnImportDecl this_mod
-             (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
+             (L loc decl@(ImportDecl { ideclExt = noExt
+                                     , ideclName = loc_imp_mod_name
+                                     , ideclPkgQual = mb_pkg
                                      , ideclSource = want_boot, ideclSafe = mod_safe
                                      , ideclQualified = qual_only, ideclImplicit = implicit
                                      , ideclAs = as_mod, ideclHiding = imp_details }))
@@ -313,10 +376,11 @@ rnImportDecl this_mod
           _           -> return ()
      )
 
-    let new_imp_decl = L loc (decl { ideclSafe = mod_safe'
+    let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'
                                    , ideclHiding = new_imp_details })
 
     return (new_imp_decl, gbl_env, imports, mi_hpc iface)
+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"
 
 -- | Calculate the 'ImportAvails' induced by an import of a particular
 -- interface, but without 'imp_mods'.
@@ -499,7 +563,7 @@ extendGlobalRdrEnvRn avails new_fixities
 
         ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
 
-        ; let fix_env' = foldl extend_fix_env fix_env new_gres
+        ; let fix_env' = foldl' extend_fix_env fix_env new_gres
               gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
 
         ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
@@ -602,7 +666,7 @@ getLocalNonValBinders fixity_env
         ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
         ; return (envs, new_bndrs) } }
   where
-    ValBindsIn _val_binds val_sigs = binds
+    ValBinds _ _val_binds val_sigs = binds
 
     for_hs_bndrs :: [Located RdrName]
     for_hs_bndrs = hsForeignDeclsBinders foreign_decls
@@ -610,7 +674,7 @@ getLocalNonValBinders fixity_env
     -- In a hs-boot file, the value binders come from the
     --  *signatures*, and there should be no foreign binders
     hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
-                        | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
+                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
 
       -- the SrcSpan attached to the input should be the span of the
       -- declaration, not just the name
@@ -637,24 +701,16 @@ getLocalNonValBinders fixity_env
                -> [(Name, [FieldLabel])]
     mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
       where
-        find_con_flds (L _ (ConDeclH98 { con_name    = L _ rdr
-                                       , con_details = RecCon cdflds }))
+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+                                       , con_args = RecCon cdflds }))
             = [( find_con_name rdr
                , concatMap find_con_decl_flds (unLoc cdflds) )]
-        find_con_flds (L _ (ConDeclGADT
-                              { con_names = rdrs
-                              , con_type = (HsIB { hsib_body = res_ty})}))
-            = map (\ (L _ rdr) -> ( find_con_name rdr
-                                  , concatMap find_con_decl_flds cdflds))
-                  rdrs
-            where
-              (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
-              cdflds = case tau of
-                 L _ (HsFunTy
-                      (L _ (HsAppsTy
-                        [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
-                 L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
-                 _                                    -> []
+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+                                        , con_args = RecCon flds }))
+            = [ ( find_con_name rdr
+                 , concatMap find_con_decl_flds (unLoc flds))
+              | L _ rdr <- rdrs ]
+
         find_con_flds _ = []
 
         find_con_name rdr
@@ -662,20 +718,22 @@ getLocalNonValBinders fixity_env
               find (\ n -> nameOccName n == rdrNameOcc rdr) names
         find_con_decl_flds (L _ x)
           = map find_con_decl_fld (cd_fld_names x)
-        find_con_decl_fld  (L _ (FieldOcc (L _ rdr) _))
+
+        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))
           = expectJust "getLocalNonValBinders/find_con_decl_fld" $
               find (\ fl -> flLabel fl == lbl) flds
           where lbl = occNameFS (rdrNameOcc rdr)
+        find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"
 
     new_assoc :: Bool -> LInstDecl GhcPs
               -> RnM ([AvailInfo], [(Name, [FieldLabel])])
     new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
       -- type instances don't bind new names
 
-    new_assoc overload_ok (L _ (DataFamInstD d))
+    new_assoc overload_ok (L _ (DataFamInstD _ d))
       = do { (avail, flds) <- new_di overload_ok Nothing d
            ; return ([avail], flds) }
-    new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
+    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
                                                       , cid_datafam_insts = adts })))
       | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
       = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
@@ -685,26 +743,32 @@ getLocalNonValBinders fixity_env
       | otherwise
       = return ([], [])    -- Do not crash on ill-formed instances
                            -- Eg   instance !Show Int   Trac #3811c
+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"
+    new_assoc _ (L _ (XInstDecl _))                 = panic "new_assoc"
 
     new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
                    -> RnM (AvailInfo, [(Name, [FieldLabel])])
-    new_di overload_ok mb_cls ti_decl
-        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
-             ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
+                                     HsIB { hsib_body = ti_decl }})
+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
+             ; let (bndrs, flds) = hsDataFamInstBinders dfid
              ; sub_names <- mapM newTopSrcBinder bndrs
              ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
              ; let avail    = AvailTC (unLoc main_name) sub_names flds'
                                   -- main_name is not bound here!
-                   fld_env  = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
              ; return (avail, fld_env) }
+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"
 
     new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
                    -> RnM (AvailInfo, [(Name, [FieldLabel])])
     new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"
 
 newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
 newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
-newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"
+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
   = do { selName <- newTopSrcBinder $ L loc $ field
        ; return $ qualFieldLbl { flSelector = selName } }
   where
@@ -803,7 +867,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                 -- NB the AvailInfo may have duplicates, and several items
                 --    for the same parent; e.g N(x) and N(y)
 
-            names  = availsToNameSet (map snd items2)
+            names  = availsToNameSetWithSelectors (map snd items2)
             keep n = not (n `elemNameSet` names)
             pruned_avails = filterAvails keep all_avails
             hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
@@ -819,8 +883,9 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
     imp_occ_env :: OccEnv (Name,    -- the name
                            AvailInfo,   -- the export item providing the name
                            Maybe Name)  -- the parent of associated types
-    imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))
-                                     | a <- all_avails, n <- availNames a]
+    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))
+                                     | a <- all_avails
+                                     , (n, occ) <- availNamesWithOccs a]
       where
         -- See Note [Dealing with imports]
         -- 'combine' is only called for associated data types which appear
@@ -835,10 +900,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                            else (name1, a2, Just p1)
         combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
 
-    lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
-    lookup_name rdr | isQual rdr              = failLookupWith (QualImportError rdr)
-                    | Just succ <- mb_success = return succ
-                    | otherwise               = failLookupWith BadImport
+    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
+    lookup_name ie rdr
+       | isQual rdr              = failLookupWith (QualImportError rdr)
+       | Just succ <- mb_success = return succ
+       | otherwise               = failLookupWith (BadImport ie)
       where
         mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
 
@@ -855,8 +921,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
               addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
             emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
               addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
-            emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $
-              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport)
+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
 
             run_lookup :: IELookupM a -> TcRn (Maybe a)
             run_lookup m = case m of
@@ -864,7 +930,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
               Succeeded a -> return (Just a)
 
             lookup_err_msg err = case err of
-              BadImport -> badImportItemErr iface decl_spec ieRdr all_avails
+              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails
               IllegalImport -> illegalImportItemErr
               QualImportError rdr -> qualImportItemErr rdr
 
@@ -882,13 +948,13 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
               -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
     lookup_ie ie = handle_bad_import $ do
       case ie of
-        IEVar (L l n) -> do
-            (name, avail, _) <- lookup_name $ ieWrappedName n
-            return ([(IEVar (L l (replaceWrappedName n name)),
+        IEVar _ (L l n) -> do
+            (name, avail, _) <- lookup_name ie $ ieWrappedName n
+            return ([(IEVar noExt (L l (replaceWrappedName n name)),
                                                   trimAvail avail name)], [])
 
-        IEThingAll (L l tc) -> do
-            (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
+        IEThingAll _ (L l tc) -> do
+            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
             let warns = case avail of
                           Avail {}                     -- e.g. f(..)
                             -> [DodgyImport $ ieWrappedName tc]
@@ -903,7 +969,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                             | otherwise
                             -> []
 
-                renamed_ie = IEThingAll (L l (replaceWrappedName tc name))
+                renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))
                 sub_avails = case avail of
                                Avail {}              -> []
                                AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
@@ -913,26 +979,30 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
               Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
                              -- associated type
 
-        IEThingAbs (L l tc')
+        IEThingAbs _ (L l tc')
             | want_hiding   -- hiding ( C )
                        -- Here the 'C' can be a data constructor
                        --  *or* a type/class, or even both
             -> let tc = ieWrappedName tc'
-                   tc_name = lookup_name tc
-                   dc_name = lookup_name (setRdrNameSpace tc srcDataName)
+                   tc_name = lookup_name ie tc
+                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
                in
                case catIELookupM [ tc_name, dc_name ] of
-                 []    -> failLookupWith BadImport
+                 []    -> failLookupWith (BadImport ie)
                  names -> return ([mkIEThingAbs tc' l name | name <- names], [])
             | otherwise
-            -> do nameAvail <- lookup_name (ieWrappedName tc')
+            -> do nameAvail <- lookup_name ie (ieWrappedName tc')
                   return ([mkIEThingAbs tc' l nameAvail]
                          , [])
 
-        IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->
+        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
           ASSERT2(null rdr_fs, ppr rdr_fs) do
-           (name, AvailTC _ ns subflds, mb_parent)
-                                         <- lookup_name (ieWrappedName rdr_tc)
+           (name, avail, mb_parent)
+               <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
+
+           let (ns,subflds) = case avail of
+                                AvailTC _ ns' subflds' -> (ns',subflds')
+                                Avail _                -> panic "filterImports"
 
            -- Look up the children in the sub-names of the parent
            let subnames = case ns of   -- The tc is first in ns,
@@ -940,15 +1010,20 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                                        -- See the AvailTC Invariant in Avail.hs
                             (n1:ns1) | n1 == name -> ns1
                                      | otherwise  -> ns
-               rdr_ns = map ieLWrappedName rdr_ns'
            case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
-             Nothing                      -> failLookupWith BadImport
-             Just (childnames, childflds) ->
+
+             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))
+                                -- We are trying to import T( a,b,c,d ), and failed
+                                -- to find 'b' and 'd'.  So we make up an import item
+                                -- to report as failing, namely T( b, d ).
+                                -- c.f. Trac #15412
+
+             Succeeded (childnames, childflds) ->
                case mb_parent of
                  -- non-associated ty/cls
                  Nothing
-                   -> return ([(IEThingWith (L l name') wc childnames'
-                                                           childflds,
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
+                                                                 childflds,
                                AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
                               [])
                    where name' = replaceWrappedName rdr_tc name
@@ -956,10 +1031,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
                          -- childnames' = postrn_ies childnames
                  -- associated ty
                  Just parent
-                   -> return ([(IEThingWith (L l name') wc childnames'
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
                                                            childflds,
                                 AvailTC name (map unLoc childnames) (map unLoc childflds)),
-                               (IEThingWith (L l name') wc childnames'
+                               (IEThingWith noExt (L l name') wc childnames'
                                                            childflds,
                                 AvailTC parent [name] [])],
                               [])
@@ -972,25 +1047,26 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
 
       where
         mkIEThingAbs tc l (n, av, Nothing    )
-          = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n)
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)
         mkIEThingAbs tc l (n, _,  Just parent)
-          = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n))
+             , AvailTC parent [n] [])
 
         handle_bad_import m = catchIELookup m $ \err -> case err of
-          BadImport | want_hiding -> return ([], [BadImportW])
-          _                       -> failLookupWith err
+          BadImport ie | want_hiding -> return ([], [BadImportW ie])
+          _                          -> failLookupWith err
 
 type IELookupM = MaybeErr IELookupError
 
 data IELookupWarning
-  = BadImportW
+  = BadImportW (IE GhcPs)
   | MissingImportList
   | DodgyImport RdrName
   -- NB. use the RdrName for reporting a "dodgy" import
 
 data IELookupError
   = QualImportError RdrName
-  | BadImport
+  | BadImport (IE GhcPs)
   | IllegalImport
 
 failLookupWith :: IELookupError -> IELookupM a
@@ -1018,8 +1094,8 @@ gresFromIE decl_spec (L loc ie, avail)
   = gresFromAvail prov_fn avail
   where
     is_explicit = case ie of
-                    IEThingAll (L _ name) -> \n -> n == ieWrappedName name
-                    _                     -> \_ -> True
+                    IEThingAll _ (L _ name) -> \n -> n == ieWrappedName name
+                    _                       -> \_ -> True
     prov_fn name
       = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
       where
@@ -1053,8 +1129,9 @@ mkChildEnv gres = foldr add emptyNameEnv gres
 findChildren :: NameEnv [a] -> Name -> [a]
 findChildren env n = lookupNameEnv env n `orElse` []
 
-lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
-               -> Maybe ([Located Name], [Located FieldLabel])
+lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]
+               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed
+                           ([Located Name], [Located FieldLabel])
 -- (lookupChildren all_kids rdr_items) maps each rdr_item to its
 -- corresponding Name all_kids, if the former exists
 -- The matching is done by FastString, not OccName, so that
@@ -1063,17 +1140,27 @@ lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
 -- the RdrName for AssocTy may have a (bogus) DataName namespace
 -- (Really the rdr_items should be FastStrings in the first place.)
 lookupChildren all_kids rdr_items
-  = do xs <- mapM doOne rdr_items
-       return (fmap concat (partitionEithers xs))
+  | null fails
+  = Succeeded (fmap concat (partitionEithers oks))
+       -- This 'fmap concat' trickily applies concat to the /second/ component
+       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])
+  | otherwise
+  = Failed fails
   where
-    doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
-      Just [Left n]            -> Just (Left (L l n))
-      Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))
-      _                        -> Nothing
+    mb_xs = map doOne rdr_items
+    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
+    oks   = [ ok      | Succeeded ok   <- mb_xs ]
+    oks :: [Either (Located Name) [Located FieldLabel]]
+
+    doOne item@(L l r)
+       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
+           Just [Left n]            -> Succeeded (Left (L l n))
+           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))
+           _                        -> Failed    item
 
     -- See Note [Children for duplicate record fields]
     kid_env = extendFsEnvList_C (++) emptyFsEnv
-                      [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
 
 
 
@@ -1181,7 +1268,7 @@ warnMissingSignatures gbl_env
              pat_syns = tcg_patsyns gbl_env
 
          -- Warn about missing signatures
-         -- Do this only when we we have a type to offer
+         -- Do this only when we have a type to offer
        ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures
        ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
        ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures
@@ -1275,13 +1362,13 @@ findImportUsage imports used_gres
               _other -> emptyNameSet -- No explicit import list => no unused-name list
 
         add_unused :: IE GhcRn -> NameSet -> NameSet
-        add_unused (IEVar (L _ n))      acc
+        add_unused (IEVar _ (L _ n))      acc
                                        = add_unused_name (ieWrappedName n) acc
-        add_unused (IEThingAbs (L _ n)) acc
+        add_unused (IEThingAbs _ (L _ n)) acc
                                        = add_unused_name (ieWrappedName n) acc
-        add_unused (IEThingAll (L _ n)) acc
+        add_unused (IEThingAll _ (L _ n)) acc
                                        = add_unused_all  (ieWrappedName n) acc
-        add_unused (IEThingWith (L _ p) wc ns fs) acc =
+        add_unused (IEThingWith _ (L _ p) wc ns fs) acc =
           add_wc_all (add_unused_with (ieWrappedName p) xs acc)
           where xs = map (ieWrappedName . unLoc) ns
                           ++ map (flSelector . unLoc) fs
@@ -1305,6 +1392,7 @@ findImportUsage imports used_gres
        -- If you use 'signum' from Num, then the user may well have
        -- imported Num(signum).  We don't want to complain that
        -- Num is not itself mentioned.  Hence the two cases in add_unused_with.
+    unused_decl (L _ (XImportDecl _)) = panic "unused_decl"
 
 extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap
 -- For each of a list of used GREs, find all the import decls that brought
@@ -1350,9 +1438,12 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
     pp_mod      = ppr (unLoc (ideclName decl))
     pp_not_used = text "is redundant"
 
+    -- In warning message, pretty-print identifiers unqualified unconditionally
+    -- to improve the consistent for ambiguous/unambiguous identifiers.
+    -- See trac#14881.
     ppr_possible_field n = case lookupNameEnv fld_env n of
-                               Just (fld, p) -> ppr p <> parens (ppr fld)
-                               Nothing  -> ppr n
+                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)
+                               Nothing  -> pprNameUnqualified n
 
     -- Print unused names in a deterministic (lexicographic) order
     sort_unused = pprWithCommas ppr_possible_field $
@@ -1381,28 +1472,9 @@ decls, and simply trim their import lists.  NB that
     from it.  Instead we just trim to an empty import list
 -}
 
-printMinimalImports :: [ImportDeclUsage] -> RnM ()
--- See Note [Printing minimal imports]
-printMinimalImports imports_w_usage
-  = do { imports' <- mapM mk_minimal imports_w_usage
-       ; this_mod <- getModule
-       ; dflags   <- getDynFlags
-       ; liftIO $
-         do { h <- openFile (mkFilename dflags this_mod) WriteMode
-            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
-              -- The neverQualify is important.  We are printing Names
-              -- but they are in the context of an 'import' decl, and
-              -- we never qualify things inside there
-              -- E.g.   import Blag( f, b )
-              -- not    import Blag( Blag.f, Blag.g )!
-       }
+getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
+getMinimalImports = mapM mk_minimal
   where
-    mkFilename dflags this_mod
-      | Just d <- dumpDir dflags = d </> basefn
-      | otherwise                = basefn
-      where
-        basefn = moduleNameString (moduleName this_mod) ++ ".imports"
-
     mk_minimal (L l decl, used, unused)
       | null unused
       , Just (False, _) <- ideclHiding decl
@@ -1422,25 +1494,25 @@ printMinimalImports imports_w_usage
     -- we want to say "T(..)", but if we're importing only a subset we want
     -- to say "T(A,B,C)".  So we have to find out what the module exports.
     to_ie _ (Avail n)
-       = [IEVar (to_ie_post_rn $ noLoc n)]
+       = [IEVar noExt (to_ie_post_rn $ noLoc n)]
     to_ie _ (AvailTC n [m] [])
-       | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]
+       | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]
     to_ie iface (AvailTC n ns fs)
       = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
                  , x == n
                  , x `elem` xs    -- Note [Partial export]
                  ] of
-           [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]
+           [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]
                 | otherwise   ->
-                   [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+                   [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
                                 (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
                                 (map noLoc fs)]
                                           -- Note [Overloaded field import]
            _other | all_non_overloaded fs
-                              -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns
+                           -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns
                                  ++ map flSelector fs
                   | otherwise ->
-                      [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+                      [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
                                 (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
                                 (map noLoc fs)]
         where
@@ -1453,6 +1525,29 @@ printMinimalImports imports_w_usage
 
           all_non_overloaded = all (not . flIsOverloaded)
 
+printMinimalImports :: [ImportDeclUsage] -> RnM ()
+-- See Note [Printing minimal imports]
+printMinimalImports imports_w_usage
+  = do { imports' <- getMinimalImports imports_w_usage
+       ; this_mod <- getModule
+       ; dflags   <- getDynFlags
+       ; liftIO $
+         do { h <- openFile (mkFilename dflags this_mod) WriteMode
+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
+              -- The neverQualify is important.  We are printing Names
+              -- but they are in the context of an 'import' decl, and
+              -- we never qualify things inside there
+              -- E.g.   import Blag( f, b )
+              -- not    import Blag( Blag.f, Blag.g )!
+       }
+  where
+    mkFilename dflags this_mod
+      | Just d <- dumpDir dflags = d </> basefn
+      | otherwise                = basefn
+      where
+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"
+
+
 to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
 to_ie_post_rn_var (L l n)
   | isDataOcc $ occName n = L l (IEPattern (L l n))
@@ -1581,10 +1676,10 @@ dodgyMsg kind tc ie
           quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
           text "but it has none" ]
 
-dodgyMsgInsert :: forall p . IdP p -> IE p
-dodgyMsgInsert tc = IEThingAll ii
+dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgyMsgInsert tc = IEThingAll noExt ii
   where
-    ii :: LIEWrappedName (IdP p)
+    ii :: LIEWrappedName (IdP (GhcPass p))
     ii = noLoc (IEName $ noLoc tc)
 
 
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index ff88dbffbc..6195309cab 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -11,6 +11,8 @@ free variables.
 -}
 
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module RnPat (-- main entry points
               rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -35,6 +37,8 @@ module RnPat (-- main entry points
 
 -- ENH: thin imports to only what is necessary for patterns
 
+import GhcPrelude
+
 import {-# SOURCE #-} RnExpr ( rnLExpr )
 import {-# SOURCE #-} RnSplice ( rnSplicePat )
 
@@ -47,13 +51,10 @@ import RnEnv
 import RnFixity
 import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
-                           , checkDupAndShadowedNames, checkTupSize
-                           , unknownSubordinateErr )
+                           , checkDupNames, checkDupAndShadowedNames
+                           , checkTupSize , unknownSubordinateErr )
 import RnTypes
 import PrelNames
-import TyCon               ( tyConName )
-import ConLike
-import Type                ( TyThing(..) )
 import Name
 import NameSet
 import RdrName
@@ -67,7 +68,8 @@ import TysWiredIn          ( nilDataCon )
 import DataCon
 import qualified GHC.LanguageExtensions as LangExt
 
-import Control.Monad       ( when, liftM, ap, unless )
+import Control.Monad       ( when, liftM, ap, guard )
+import qualified Data.List.NonEmpty as NE
 import Data.Ratio
 
 {-
@@ -320,10 +322,11 @@ rnPats ctxt pats thing_inside
           --    complain *twice* about duplicates e.g. f (x,x) = ...
           --
           -- See note [Don't report shadowing for pattern synonyms]
-        ; unless (isPatSynCtxt ctxt)
-              (addErrCtxt doc_pat $
-                checkDupAndShadowedNames envs_before $
-                collectPatsBinders pats')
+        ; let bndrs = collectPatsBinders pats'
+        ; addErrCtxt doc_pat $
+          if isPatSynCtxt ctxt
+             then checkDupNames bndrs
+             else checkDupAndShadowedNames envs_before bndrs
         ; thing_inside pats' } }
   where
     doc_pat = text "In" <+> pprMatchContext ctxt
@@ -377,17 +380,20 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
 rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
 
 rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
-rnPatAndThen _  (WildPat _)   = return (WildPat placeHolderType)
-rnPatAndThen mk (ParPat pat)  = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
-rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
-rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
-rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM
-                                        ; name <- newPatName mk (L loc rdr)
-                                        ; return (VarPat (L l name)) }
+rnPatAndThen _  (WildPat _)   = return (WildPat noExt)
+rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (ParPat x pat') }
+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (LazyPat x pat') }
+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (BangPat x pat') }
+rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
+                                          ; name <- newPatName mk (L loc rdr)
+                                          ; return (VarPat x (L l name)) }
      -- we need to bind pattern variables for view pattern expressions
      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
 
-rnPatAndThen mk (SigPatIn pat sig)
+rnPatAndThen mk (SigPat sig pat )
   -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
   -- important to rename its type signature _before_ renaming the rest of the
   -- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -399,21 +405,21 @@ rnPatAndThen mk (SigPatIn pat sig)
   -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
   = do { sig' <- rnHsSigCps sig
        ; pat' <- rnLPatAndThen mk pat
-       ; return (SigPatIn pat' sig') }
+       ; return (SigPat sig' pat' ) }
 
-rnPatAndThen mk (LitPat lit)
+rnPatAndThen mk (LitPat x lit)
   | HsString src s <- lit
   = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
        ; if ovlStr
          then rnPatAndThen mk
-                           (mkNPat (noLoc (mkHsIsString src s placeHolderType))
+                           (mkNPat (noLoc (mkHsIsString src s))
                                       Nothing)
          else normal_lit }
   | otherwise = normal_lit
   where
-    normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) }
+    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
 
-rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
+rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
   = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
        ; mb_neg' -- See Note [Negative zero]
            <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
@@ -425,9 +431,9 @@ rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
                                   (Nothing, Nothing) -> positive
                                   (Just _ , Just _ ) -> positive
        ; eq' <- liftCpsFV $ lookupSyntaxName eqName
-       ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
+       ; return (NPat x (L l lit') mb_neg' eq') }
 
-rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
+rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
   = do { new_name <- newPatName mk rdr
        ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
                                                 -- We skip negateName as
@@ -435,16 +441,16 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
                                                 -- sense in n + k patterns
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
-       ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
-                           (L l lit') lit' ge minus placeHolderType) }
+       ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
+                             (L l lit') lit' ge minus) }
                 -- The Report says that n+k patterns must be in Integral
 
-rnPatAndThen mk (AsPat rdr pat)
+rnPatAndThen mk (AsPat x rdr pat)
   = do { new_name <- newPatLName mk rdr
        ; pat' <- rnLPatAndThen mk pat
-       ; return (AsPat new_name pat') }
+       ; return (AsPat x new_name pat') }
 
-rnPatAndThen mk p@(ViewPat expr pat _ty)
+rnPatAndThen mk p@(ViewPat x expr pat)
   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
                       ; checkErr vp_flag (badViewPat p) }
          -- Because of the way we're arranging the recursive calls,
@@ -453,45 +459,40 @@ rnPatAndThen mk p@(ViewPat expr pat _ty)
        ; pat' <- rnLPatAndThen mk pat
        -- Note: at this point the PreTcType in ty can only be a placeHolder
        -- ; return (ViewPat expr' pat' ty) }
-       ; return (ViewPat expr' pat' placeHolderType) }
+       ; return (ViewPat x expr' pat') }
 
 rnPatAndThen mk (ConPatIn con stuff)
    -- rnConPatAndThen takes care of reconstructing the pattern
    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
   = case unLoc con == nameRdrName (dataConName nilDataCon) of
       True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
-                    ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)
+                    ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
                                  else rnConPatAndThen mk con stuff}
       False   -> rnConPatAndThen mk con stuff
 
-rnPatAndThen mk (ListPat pats _ _)
+rnPatAndThen mk (ListPat _ pats)
   = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
        ; pats' <- rnLPatsAndThen mk pats
        ; case opt_OverloadedLists of
           True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
-                     ; return (ListPat pats' placeHolderType
-                                       (Just (placeHolderType, to_list_name)))}
-          False -> return (ListPat pats' placeHolderType Nothing) }
-
-rnPatAndThen mk (PArrPat pats _)
-  = do { pats' <- rnLPatsAndThen mk pats
-       ; return (PArrPat pats' placeHolderType) }
+                     ; return (ListPat (Just to_list_name) pats')}
+          False -> return (ListPat Nothing pats') }
 
-rnPatAndThen mk (TuplePat pats boxed _)
+rnPatAndThen mk (TuplePat x pats boxed)
   = do { liftCps $ checkTupSize (length pats)
        ; pats' <- rnLPatsAndThen mk pats
-       ; return (TuplePat pats' boxed []) }
+       ; return (TuplePat x pats' boxed) }
 
-rnPatAndThen mk (SumPat pat alt arity _)
+rnPatAndThen mk (SumPat x pat alt arity)
   = do { pat <- rnLPatAndThen mk pat
-       ; return (SumPat pat alt arity PlaceHolder)
+       ; return (SumPat x pat alt arity)
        }
 
 -- If a splice has been run already, just rename the result.
-rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
-  = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
 
-rnPatAndThen mk (SplicePat splice)
+rnPatAndThen mk (SplicePat _ splice)
   = do { eith <- liftCpsFV $ rnSplicePat splice
        ; case eith of   -- See Note [rnSplicePat] in RnSplice
            Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed
@@ -534,7 +535,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
        ; flds' <- mapM rn_field (flds `zip` [1..])
        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
   where
-    mkVarPat l n = VarPat (L l n)
+    mkVarPat l n = VarPat noExt (L l n)
     rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
                                                         (hsRecFieldArg fld)
                                 ; return (L l (fld { hsRecFieldArg = arg' })) }
@@ -568,7 +569,7 @@ rnHsRecFields
 -- This surprisingly complicated pass
 --   a) looks up the field name (possibly using disambiguation)
 --   b) fills in puns and dot-dot stuff
--- When we we've finished, we've renamed the LHS, but not the RHS,
+-- When we've finished, we've renamed the LHS, but not the RHS,
 -- of each x=e binding
 --
 -- This is used for record construction and pattern-matching, but not updates.
@@ -576,7 +577,7 @@ rnHsRecFields
 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
   = do { pun_ok      <- xoptM LangExt.RecordPuns
        ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
-       ; parent <- check_disambiguation disambig_ok mb_con
+       ; let parent = guard disambig_ok >> mb_con
        ; flds1  <- mapM (rn_fld pun_ok parent) flds
        ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
        ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
@@ -585,25 +586,17 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
        ; return (all_flds, mkFVs (getFieldIds all_flds)) }
   where
     mb_con = case ctxt of
-                HsRecFieldCon con | not (isUnboundName con) -> Just con
-                HsRecFieldPat con | not (isUnboundName con) -> Just con
-                _ {- update or isUnboundName con -}         -> Nothing
-           -- The unbound name test is because if the constructor
-           -- isn't in scope the constructor lookup will add an error
-           -- add an error, but still return an unbound name.
-           -- We don't want that to screw up the dot-dot fill-in stuff.
-
-    doc = case mb_con of
-            Nothing  -> text "constructor field name"
-            Just con -> text "field of constructor" <+> quotes (ppr con)
+                HsRecFieldCon con  -> Just con
+                HsRecFieldPat con  -> Just con
+                _ {- update -}     -> Nothing
 
     rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
            -> RnM (LHsRecField GhcRn (Located arg))
     rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
-                                              = L loc (FieldOcc (L ll lbl) _)
+                                              = L loc (FieldOcc _ (L ll lbl))
                                           , hsRecFieldArg = arg
                                           , hsRecPun      = pun }))
-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
            ; arg' <- if pun
                      then do { checkErr pun_ok (badPun (L loc lbl))
                                -- Discard any module qualifier (#11662)
@@ -611,20 +604,22 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                              ; return (L loc (mk_arg loc arg_rdr)) }
                      else return arg
            ; return (L l (HsRecField { hsRecFieldLbl
-                                         = L loc (FieldOcc (L ll lbl) sel)
+                                         = L loc (FieldOcc sel (L ll lbl))
                                      , hsRecFieldArg = arg'
                                      , hsRecPun      = pun })) }
+    rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
+      = panic "rnHsRecFields"
 
     rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
               -> Maybe Name -- The constructor (Nothing for an
                                 --    out of scope constructor)
               -> [LHsRecField GhcRn (Located arg)] -- Explicit fields
               -> RnM [LHsRecField GhcRn (Located arg)]   -- Filled in .. fields
-    rn_dotdot Nothing _mb_con _flds     -- No ".." at all
-      = return []
-    rn_dotdot (Just {}) Nothing _flds   -- Constructor out of scope
-      = return []
     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
+      | not (isUnboundName con) -- This test is because if the constructor
+                                -- isn't in scope the constructor lookup will add
+                                -- an error but still return an unbound name. We
+                                -- don't want that to screw up the dot-dot fill-in stuff.
       = ASSERT( flds `lengthIs` n )
         do { loc <- getSrcSpanM -- Rather approximate
            ; dd_flag <- xoptM LangExt.RecordWildCards
@@ -654,64 +649,32 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
 
            ; addUsedGREs dot_dot_gres
            ; return [ L loc (HsRecField
-                        { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
+                        { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
                         , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
                         , hsRecPun      = False })
                     | fl <- dot_dot_fields
                     , let sel     = flSelector fl
                     , let arg_rdr = mkVarUnqual (flLabel fl) ] }
 
-    check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
-    -- When disambiguation is on, return name of parent tycon.
-    check_disambiguation disambig_ok mb_con
-      | disambig_ok, Just con <- mb_con
-      = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
-      | otherwise = return Nothing
-
-    find_tycon :: GlobalRdrEnv -> Name {- DataCon -}
-               -> Maybe Name {- TyCon -}
-    -- Return the parent *type constructor* of the data constructor
-    -- (that is, the parent of the data constructor),
-    -- or 'Nothing' if it is a pattern synonym or not in scope.
-    -- That's the parent to use for looking up record fields.
-    find_tycon env con_name
-      | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
-      = Just (tyConName (dataConTyCon dc))
-        -- Special case for [], which is built-in syntax
-        -- and not in the GlobalRdrEnv (Trac #8448)
-
-      | Just gre <- lookupGRE_Name env con_name
-      = case gre_par gre of
-          ParentIs p -> Just p
-          _          -> Nothing   -- Can happen if the con_name
-                                  -- is for a pattern synonym
-
-      | otherwise = Nothing
-        -- Data constructor not lexically in scope at all
-        -- See Note [Disambiguation and Template Haskell]
-
-    dup_flds :: [[RdrName]]
+    rn_dotdot _dotdot _mb_con _flds
+      = return []
+      -- _dotdot = Nothing => No ".." at all
+      -- _mb_con = Nothing => Record update
+      -- _mb_con = Just unbound => Out of scope data constructor
+
+    dup_flds :: [NE.NonEmpty RdrName]
         -- Each list represents a RdrName that occurred more than once
         -- (the list contains all occurrences)
         -- Each list in dup_fields is non-empty
     (_, dup_flds) = removeDups compare (getFieldLbls flds)
 
 
-{- Note [Disambiguation and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (Trac #12130)
-   module Foo where
-     import M
-     b = $(funny)
-
-   module M(funny) where
-     data T = MkT { x :: Int }
-     funny :: Q Exp
-     funny = [| MkT { x = 3 } |]
-
-When we splice, neither T nor MkT are lexically in scope, so find_tycon will
-fail.  But there is no need for disambiguation anyway, so we just return Nothing
--}
+-- NB: Consider this:
+--      module Foo where { data R = R { fld :: Int } }
+--      module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
 
 rnHsRecUpdFields
     :: [LHsRecUpdField GhcPs]
@@ -750,7 +713,7 @@ rnHsRecUpdFields flds
                      then do { checkErr pun_ok (badPun (L loc lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L loc (HsVar (L loc arg_rdr))) }
+                             ; return (L loc (HsVar noExt (L loc arg_rdr))) }
                      else return arg
            ; (arg'', fvs) <- rnLExpr arg'
 
@@ -760,16 +723,16 @@ rnHsRecUpdFields flds
                           Right _       -> fvs
                  lbl' = case sel of
                           Left sel_name ->
-                                     L loc (Unambiguous (L loc lbl) sel_name)
+                                     L loc (Unambiguous sel_name  (L loc lbl))
                           Right [sel_name] ->
-                                     L loc (Unambiguous (L loc lbl) sel_name)
-                          Right _ -> L loc (Ambiguous   (L loc lbl) PlaceHolder)
+                                     L loc (Unambiguous sel_name  (L loc lbl))
+                          Right _ -> L loc (Ambiguous   noExt     (L loc lbl))
 
            ; return (L l (HsRecField { hsRecFieldLbl = lbl'
                                      , hsRecFieldArg = arg''
                                      , hsRecPun      = pun }), fvs') }
 
-    dup_flds :: [[RdrName]]
+    dup_flds :: [NE.NonEmpty RdrName]
         -- Each list represents a RdrName that occurred more than once
         -- (the list contains all occurrences)
         -- Each list in dup_fields is non-empty
@@ -784,7 +747,7 @@ getFieldLbls :: [LHsRecField id arg] -> [RdrName]
 getFieldLbls flds
   = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
 
-getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
+getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
 getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
 
 needFlagDotDot :: HsRecFieldContext -> SDoc
@@ -803,10 +766,10 @@ badPun :: Located RdrName -> SDoc
 badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
                    text "Use NamedFieldPuns to permit this"]
 
-dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
 dupFieldErr ctxt dups
   = hsep [text "duplicate field name",
-          quotes (ppr (head dups)),
+          quotes (ppr (NE.head dups)),
           text "in record", pprRFC ctxt]
 
 pprRFC :: HsRecFieldContext -> SDoc
@@ -868,11 +831,10 @@ rnOverLit origLit
         ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
             <- lookupSyntaxName std_name
         ; let rebindable = case from_thing_name of
-                                HsVar (L _ v) -> v /= std_name
-                                _             -> panic "rnOverLit"
+                                HsVar _ (L _ v) -> v /= std_name
+                                _               -> panic "rnOverLit"
         ; let lit' = lit { ol_witness = from_thing_name
-                         , ol_rebindable = rebindable
-                         , ol_type = placeHolderType }
+                         , ol_ext = rebindable }
         ; if isNegativeZeroOverLit lit'
           then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
                       <- lookupSyntaxName negateName
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 244f46b3c0..91c46b3cc4 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -14,6 +14,8 @@ module RnSource (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} RnExpr( rnLExpr )
 import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
 
@@ -27,7 +29,7 @@ import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
                         , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
                         , checkShadowedRdrNames, warnUnusedTypePatterns
                         , extendTyVarEnvFVRn, newLocalBndrsRn )
-import RnUnbound        ( mkUnboundName )
+import RnUnbound        ( mkUnboundName, notInScopeErr )
 import RnNames
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcAnnotations    ( annCtxt )
@@ -36,7 +38,6 @@ import TcRnMonad
 import ForeignCall      ( CCallTarget(..) )
 import Module
 import HscTypes         ( Warnings(..), plusWarns )
-import Class            ( FunDep )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
                         , monadClassName, returnMName, thenMName
                         , monadFailClassName, failMName, failMName_preMFP
@@ -49,11 +50,11 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
-import BasicTypes       ( DerivStrategy, RuleName, pprRuleName )
+import BasicTypes       ( RuleName, pprRuleName )
 import FastString
 import SrcLoc
 import DynFlags
-import Util             ( debugIsOn, lengthExceeds, partitionWith )
+import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
 import HscTypes         ( HscEnv, hsc_dflags )
 import ListSetOps       ( findDupsEq, removeDups, equivClasses )
 import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
@@ -63,8 +64,9 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Control.Arrow ( first )
-import Data.List ( sortBy, mapAccumL )
-import Data.Maybe ( isJust )
+import Data.List ( mapAccumL )
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
 
 {- | @rnSourceDecl@ "renames" declarations.
@@ -95,7 +97,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_fords   = foreign_decls,
                             hs_defds   = default_decls,
                             hs_ruleds  = rule_decls,
-                            hs_vects   = vect_decls,
                             hs_docs    = docs })
  = do {
    -- (A) Process the fixity declarations, creating a mapping from
@@ -109,7 +110,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    --
    --        * Class ops, data constructors, and record fields,
    --          because they do not have value declarations.
-   --          Aso step (C) depends on datacons and record fields
    --
    --        * For hs-boot files, include the value signatures
    --          Again, they have no value declarations
@@ -128,8 +128,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
 
    -- (D2) Rename the left-hand sides of the value bindings.
-   --     This depends on everything from (B) being in scope,
-   --     and on (C) for resolving record wild cards.
+   --     This depends on everything from (B) being in scope.
    --     It uses the fixity env from (A) to bind fixities for view patterns.
    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 
@@ -138,7 +137,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                                                     -- They are already in scope
    traceRn "rnSrcDecls" (ppr id_bndrs) ;
    tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
-   traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs)));
    setEnvs tc_envs $ do {
 
    --  Now everything is in scope, as the remaining renaming assumes.
@@ -173,7 +171,8 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- Rename fixity declarations and error if we try to
    -- fix something from another module (duplicates were checked in (A))
    let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
-   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
+   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
+                        fix_decls ;
 
    -- Rename deprec decls;
    -- check for duplicates and ensure that deprecated things are defined locally
@@ -185,18 +184,18 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
                                    rnList rnHsRuleDecls rule_decls ;
                            -- Inside RULES, scoped type variables are on
-   (rn_vect_decls,    src_fvs3) <- rnList rnHsVectDecl    vect_decls ;
-   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
-   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
-   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
-   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
-   (rn_splice_decls,  src_fvs8) <- rnList rnSpliceDecl    splice_decls ;
+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
    last_tcg_env <- getGblEnv ;
    -- (I) Compute the results and return
-   let {rn_group = HsGroup { hs_valds   = rn_val_decls,
+   let {rn_group = HsGroup { hs_ext     = noExt,
+                             hs_valds   = rn_val_decls,
                              hs_splcds  = rn_splice_decls,
                              hs_tyclds  = rn_tycl_decls,
                              hs_derivds = rn_deriv_decls,
@@ -207,13 +206,12 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                              hs_annds  = rn_ann_decls,
                              hs_defds  = rn_default_decls,
                              hs_ruleds = rn_rule_decls,
-                             hs_vects  = rn_vect_decls,
                              hs_docs   = rn_docs } ;
 
         tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
-                              src_fvs6, src_fvs7, src_fvs8] ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+                              src_fvs5, src_fvs6, src_fvs7] ;
                 -- It is tiresome to gather the binders from type and class decls
 
         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
@@ -224,11 +222,11 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                         in -- we return the deprecs in the env, not in the HsGroup above
                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
        } ;
-   traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;
    traceRn "finish rnSrc" (ppr rn_group) ;
    traceRn "finish Dus" (ppr src_dus ) ;
    return (final_tcg_env, rn_group)
                     }}}}
+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
 
 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 -- This function could be defined lower down in the module hierarchy,
@@ -263,45 +261,6 @@ rnDocDecl (DocGroup lev doc) = do
 {-
 *********************************************************
 *                                                       *
-        Source-code fixity declarations
-*                                                       *
-*********************************************************
--}
-
-rnSrcFixityDecls :: NameSet -> [LFixitySig GhcPs] -> RnM [LFixitySig GhcRn]
--- Rename the fixity decls, so we can put
--- the renamed decls in the renamed syntax tree
--- Errors if the thing being fixed is not defined locally.
---
--- The returned FixitySigs are not actually used for anything,
--- except perhaps the GHCi API
-rnSrcFixityDecls bndr_set fix_decls
-  = do fix_decls <- mapM rn_decl fix_decls
-       return (concat fix_decls)
-  where
-    sig_ctxt = TopSigCtxt bndr_set
-
-    rn_decl :: LFixitySig GhcPs -> RnM [LFixitySig GhcRn]
-        -- GHC extension: look up both the tycon and data con
-        -- for con-like things; hence returning a list
-        -- If neither are in scope, report an error; otherwise
-        -- return a fixity sig for each (slightly odd)
-    rn_decl (L loc (FixitySig fnames fixity))
-      = do names <- mapM lookup_one fnames
-           return [ L loc (FixitySig name fixity)
-                  | name <- names ]
-
-    lookup_one :: Located RdrName -> RnM [Located Name]
-    lookup_one (L name_loc rdr_name)
-      = setSrcSpan name_loc $
-                    -- this lookup will fail if the definition isn't local
-        do names <- lookupLocalTcNames sig_ctxt what rdr_name
-           return [ L name_loc name | (_, name) <- names ]
-    what = text "fixity signature"
-
-{-
-*********************************************************
-*                                                       *
         Source-code deprecations declarations
 *                                                       *
 *********************************************************
@@ -320,7 +279,7 @@ rnSrcWarnDecls _ []
 
 rnSrcWarnDecls bndr_set decls'
   = do { -- check for duplicates
-       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
+       ; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups
                           in addErrAt loc (dupWarnDecl lrdr' rdr))
                warn_rdr_dups
        ; pairs_s <- mapM (addLocM rn_deprec) decls
@@ -330,18 +289,19 @@ rnSrcWarnDecls bndr_set decls'
 
    sig_ctxt = TopSigCtxt bndr_set
 
-   rn_deprec (Warning rdr_names txt)
+   rn_deprec (Warning _ rdr_names txt)
        -- ensures that the names are defined locally
      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                 rdr_names
           ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
+   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
 
    what = text "deprecation"
 
-   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
+   warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns)
                                                decls
 
-findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
+findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
 
 -- look for duplicates among the OccNames;
@@ -363,13 +323,14 @@ dupWarnDecl (L loc _) rdr_name
 -}
 
 rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
-rnAnnDecl ann@(HsAnnotation s provenance expr)
+rnAnnDecl ann@(HsAnnotation _ s provenance expr)
   = addErrCtxt (annCtxt ann) $
     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
        ; (expr', expr_fvs) <- setStage (Splice Untyped) $
                               rnLExpr expr
-       ; return (HsAnnotation s provenance' expr',
+       ; return (HsAnnotation noExt s provenance' expr',
                  provenance_fvs `plusFV` expr_fvs) }
+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
 
 rnAnnProvenance :: AnnProvenance RdrName
                 -> RnM (AnnProvenance Name, FreeVars)
@@ -386,11 +347,12 @@ rnAnnProvenance provenance = do
 -}
 
 rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
-rnDefaultDecl (DefaultDecl tys)
+rnDefaultDecl (DefaultDecl _ tys)
   = do { (tys', fvs) <- rnLHsTypes doc_str tys
-       ; return (DefaultDecl tys', fvs) }
+       ; return (DefaultDecl noExt tys', fvs) }
   where
     doc_str = DefaultDeclCtx
+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
 
 {-
 *********************************************************
@@ -410,24 +372,26 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
        ; let unitId = thisPackage $ hsc_dflags topEnv
              spec'      = patchForeignImport unitId spec
 
-       ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
-                               , fd_co = noForeignImportCoercionYet
+       ; return (ForeignImport { fd_i_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
                                , fd_fi = spec' }, fvs) }
 
 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
   = do { name' <- lookupLocatedOccRn name
        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
-       ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
-                               , fd_co = noForeignExportCoercionYet
+       ; return (ForeignExport { fd_e_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
                                , fd_fe = spec }
                 , fvs `addOneFV` unLoc name') }
         -- NB: a foreign export is an *occurrence site* for name, so
         --     we add it to the free-variable list.  It might, for example,
         --     be imported from another module
 
+rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"
+
 -- | For Windows DLLs we need to know what packages imported symbols are from
 --      to generate correct calls. Imported symbols are tagged with the current
---      package, so if they get inlined across a package boundry we'll still
+--      package, so if they get inlined across a package boundary we'll still
 --      know where they're from.
 --
 patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
@@ -458,15 +422,19 @@ patchCCallTarget unitId callTarget =
 rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
   = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
-       ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
+       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
 
 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
   = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
-       ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
+       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
 
 rnSrcInstDecl (ClsInstD { cid_inst = cid })
-  = do { (cid', fvs) <- rnClsInstDecl cid
-       ; return (ClsInstD { cid_inst = cid' }, fvs) }
+  = do { traceRn "rnSrcIstDecl {" (ppr cid)
+       ; (cid', fvs) <- rnClsInstDecl cid
+       ; traceRn "rnSrcIstDecl end }" empty
+       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }
+
+rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
 
 -- | Warn about non-canonical typeclass instance declarations
 --
@@ -613,9 +581,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
     -- binding, and return @Just rhsName@ if this is the case
     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
     isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
-        | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
-        , L _ EmptyLocalBinds <- lbinds
-        , L _ (HsVar (L _ rhsName)) <- body  = Just rhsName
+        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
+        , L _ (EmptyLocalBinds _) <- lbinds
+        , L _ (HsVar _ (L _ rhsName)) <- body  = Just rhsName
     isAliasMG _ = Nothing
 
     -- got "lhs = rhs" but expected something different
@@ -696,7 +664,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 
        ; let all_fvs = meth_fvs `plusFV` more_fvs
                                 `plusFV` inst_fvs
-       ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
+       ; return (ClsInstDecl { cid_ext = noExt
+                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
                              , cid_sigs = uprags', cid_tyfam_insts = ats'
                              , cid_overlap_mode = oflag
                              , cid_datafam_insts = adts' },
@@ -711,45 +680,56 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
              --     the instance context after renaming.  This is a bit
              --     strange, but should not matter (and it would be more work
              --     to remove the context).
-
-rnFamInstDecl :: HsDocContext
-              -> Maybe (Name, [Name]) -- Nothing => not associated
-                                        -- Just (cls,tvs) => associated,
-                                        --   and gives class and tyvars of the
-                                        --   parent instance delc
-              -> Located RdrName
-              -> HsTyPats GhcPs
-              -> rhs
-              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-              -> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars)
-rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
+
+rnFamInstEqn :: HsDocContext
+             -> Maybe (Name, [Name]) -- Nothing => not associated
+                                     -- Just (cls,tvs) => associated,
+                                     --   and gives class and tyvars of the
+                                     --   parent instance delc
+             -> [Located RdrName]    -- Kind variables from the equation's RHS
+             -> FamInstEqn GhcPs rhs
+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
+rnFamInstEqn doc mb_cls rhs_kvars
+    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                               , feqn_pats   = pats
+                               , feqn_fixity = fixity
+                               , feqn_rhs    = payload }}) rn_payload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
-                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)
+                     []             -> pprPanic "rnFamInstEqn" (ppr tycon)
                      (L loc _ : []) -> loc
                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
 
        ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
+       ; let pat_vars = freeKiTyVarsAllVars $
+                        rmDupsInRdrTyVars pat_kity_vars_with_dups
              -- Use the "...Dups" form because it's needed
              -- below to report unsed binder on the LHS
-       ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
-                      freeKiTyVarsAllVars $
-                      rmDupsInRdrTyVars pat_kity_vars_with_dups
+       ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
+
+             -- Make sure to filter out the kind variables that were explicitly
+             -- bound in the type patterns.
+       ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
+       ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
+
+       ; let all_var_names = pat_var_names ++ payload_var_names
 
              -- All the free vars of the family patterns
              -- with a sensible binding location
        ; ((pats', payload'), fvs)
-              <- bindLocalNamesFV var_names $
+              <- bindLocalNamesFV all_var_names $
                  do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
-                    ; (payload', rhs_fvs) <- rnPayload doc payload
+                    ; (payload', rhs_fvs) <- rn_payload doc payload
 
                        -- Report unused binders on the LHS
                        -- See Note [Unused type variables in family instances]
-                    ; let groups :: [[Located RdrName]]
+                    ; let groups :: [NonEmpty (Located RdrName)]
                           groups = equivClasses cmpLocated $
                                    freeKiTyVarsAllVars pat_kity_vars_with_dups
                     ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
-                                     [ tv | (tv:_:_) <- groups ]
+                                     [ tv | (tv :| (_:_)) <- groups ]
                           -- Add to the used variables
                           --  a) any variables that appear *more than once* on the LHS
                           --     e.g.   F a Int a = Bool
@@ -761,13 +741,13 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                           inst_tvs = case mb_cls of
                                        Nothing            -> []
                                        Just (_, inst_tvs) -> inst_tvs
-                    ; warnUnusedTypePatterns var_names tv_nms_used
+                    ; warnUnusedTypePatterns pat_var_names tv_nms_used
 
                          -- See Note [Renaming associated types]
                     ; let bad_tvs = case mb_cls of
                                       Nothing           -> []
                                       Just (_,cls_tkvs) -> filter is_bad cls_tkvs
-                          var_name_set = mkNameSet var_names
+                          var_name_set = mkNameSet all_var_names
 
                           is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
                                         && not (cls_tkv `elemNameSet` var_name_set)
@@ -776,74 +756,76 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                     ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
 
        ; let anon_wcs = concatMap collectAnonWildCards pats'
-             all_ibs  = anon_wcs ++ var_names
+             all_ibs  = anon_wcs ++ all_var_names
                         -- all_ibs: include anonymous wildcards in the implicit
                         -- binders In a type pattern they behave just like any
                         -- other type variable except for being anoymous.  See
                         -- Note [Wildcards in family instances]
              all_fvs  = fvs `addOneFV` unLoc tycon'
-
-       ; return (tycon',
-                 HsIB { hsib_body = pats'
-                      , hsib_vars = all_ibs
-                      , hsib_closed = True },
-                 payload',
+                        -- type instance => use, hence addOneFV
+
+       ; return (HsIB { hsib_ext = all_ibs
+                      , hsib_body
+                          = FamEqn { feqn_ext    = noExt
+                                   , feqn_tycon  = tycon'
+                                   , feqn_pats   = pats'
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = payload' } },
                  all_fvs) }
-             -- type instance => use, hence addOneFV
+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
 
 rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl GhcPs
                 -> RnM (TyFamInstDecl GhcRn, FreeVars)
-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
   = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
-       ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
-                               , tfid_fvs = fvs }, fvs) }
+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
 
 rnTyFamInstEqn :: Maybe (Name, [Name])
                -> TyFamInstEqn GhcPs
                -> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
-                                , tfe_pats  = pats
-                                , tfe_fixity = fixity
-                                , tfe_rhs   = rhs })
-  = do { (tycon', pats', rhs', fvs) <-
-           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
-       ; return (TyFamEqn { tfe_tycon = tycon'
-                          , tfe_pats  = pats'
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs' }, fvs) }
+rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+                                                     , feqn_rhs   = rhs }})
+  = do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs
+       ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
+rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
 
 rnTyFamDefltEqn :: Name
                 -> TyFamDefltEqn GhcPs
                 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
-rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
-                              , tfe_pats  = tyvars
-                              , tfe_fixity = fixity
-                              , tfe_rhs   = rhs })
-  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
+rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
+                            , feqn_pats   = tyvars
+                            , feqn_fixity = fixity
+                            , feqn_rhs    = rhs })
+  = do { kvs <- extractHsTyRdrTyVarsKindVars rhs
+       ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
     do { tycon'      <- lookupFamInstName (Just cls) tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
-       ; return (TyFamEqn { tfe_tycon = tycon'
-                          , tfe_pats  = tyvars'
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs' }, fvs) }
+       ; return (FamEqn { feqn_ext    = noExt
+                        , feqn_tycon  = tycon'
+                        , feqn_pats   = tyvars'
+                        , feqn_fixity = fixity
+                        , feqn_rhs    = rhs' }, fvs) } }
   where
     ctx = TyFamilyCtx tycon
+rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
 
 rnDataFamInstDecl :: Maybe (Name, [Name])
                   -> DataFamInstDecl GhcPs
                   -> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
-                                          , dfid_pats  = pats
-                                          , dfid_fixity = fixity
-                                          , dfid_defn  = defn })
-  = do { (tycon', pats', (defn', _), fvs) <-
-           rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
-       ; return (DataFamInstDecl { dfid_tycon = tycon'
-                                 , dfid_pats  = pats'
-                                 , dfid_fixity = fixity
-                                 , dfid_defn  = defn'
-                                 , dfid_fvs   = fvs }, fvs) }
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+                           FamEqn { feqn_tycon = tycon
+                                  , feqn_rhs   = rhs }})})
+  = do { rhs_kvs <- extractDataDefnKindVars rhs
+       ; (eqn', fvs) <-
+           rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "rnDataFamInstDecl"
+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "rnDataFamInstDecl"
 
 -- Renaming of the associated types in instances.
 
@@ -886,7 +868,7 @@ is the same as
 
 This is implemented as follows: during renaming anonymous wild cards
 '_' are given freshly generated names. These names are collected after
-renaming (rnFamInstDecl) and used to make new type variables during
+renaming (rnFamInstEqn) and used to make new type variables during
 type checking (tc_fam_ty_pats). One should not confuse these wild
 cards with the ones from partial type signatures. The latter generate
 fresh meta-variables whereas the former generate fresh skolems.
@@ -912,7 +894,7 @@ when
             type T (a,_) = a
    would be rejected.  So we should not complain about an unused variable b
 
-As usual, the warnings are not reported for for type variables with names
+As usual, the warnings are not reported for type variables with names
 beginning with an underscore.
 
 Extra-constraints wild cards are not supported in type/data family
@@ -922,7 +904,7 @@ Relevant tickets: #3699, #10586, #10982 and #11451.
 
 Note [Renaming associated types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Check that the RHS of the decl mentions only type variables
+Check that the RHS of the decl mentions only type variables that are explicitly
 bound on the LHS.  For example, this is not ok
    class C a b where
       type F a x :: *
@@ -930,13 +912,26 @@ bound on the LHS.  For example, this is not ok
       type F (p,q) x = (x, r)   -- BAD: mentions 'r'
 c.f. Trac #5515
 
-The same thing applies to kind variables, of course (Trac #7938, #9574):
+Kind variables, on the other hand, are allowed to be implicitly or explicitly
+bound. As examples, this (#9574) is acceptable:
    class Funct f where
       type Codomain f :: *
    instance Funct ('KProxy :: KProxy o) where
+      -- o is implicitly bound by the kind signature
+      -- of the LHS type pattern ('KProxy)
       type Codomain 'KProxy = NatTr (Proxy :: o -> *)
-Here 'o' is mentioned on the RHS of the Codomain function, but
-not on the LHS.
+And this (#14131) is also acceptable:
+    data family Nat :: k -> k -> *
+    -- k is implicitly bound by an invisible kind pattern
+    newtype instance Nat :: (k -> *) -> (k -> *) -> * where
+      Nat :: (forall xx. f xx -> g xx) -> Nat f g
+We could choose to disallow this, but then associated type families would not
+be able to be as expressive as top-level type synonyms. For example, this type
+synonym definition is allowed:
+    type T = (Nothing :: Maybe a)
+So for parity with type synonyms, we also allow:
+    type family   T :: Maybe a
+    type instance T = (Nothing :: Maybe a)
 
 All this applies only for *instance* declarations.  In *class*
 declarations there is no RHS to worry about, and the class variables
@@ -958,14 +953,17 @@ Here 'k' is in scope in the kind signature, just like 'x'.
 -}
 
 rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
+rnSrcDerivDecl (DerivDecl _ ty mds overlap)
   = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
-       ; deriv_strats_ok     <- xoptM LangExt.DerivingStrategies
        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
-       ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
-           illegalDerivStrategyErr $ fmap unLoc deriv_strat
-       ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
-       ; return (DerivDecl ty' deriv_strat overlap, fvs) }
+       ; (mds', ty', fvs)
+           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
+              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
+              rnHsSigWcType DerivDeclCtx ty
+       ; return (DerivDecl noExt ty' mds' overlap, fvs) }
+  where
+    loc = getLoc $ hsib_body $ hswc_body ty
+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"
 
 standaloneDerivErr :: SDoc
 standaloneDerivErr
@@ -981,12 +979,13 @@ standaloneDerivErr
 -}
 
 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules src rules)
+rnHsRuleDecls (HsRules _ src rules)
   = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
-       ; return (HsRules src rn_rules,fvs) }
+       ; return (HsRules noExt src rn_rules,fvs) }
+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
 
 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
+rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
   = do { let rdr_names_w_loc = map get_var vars
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
@@ -995,11 +994,14 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
        ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
-       ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+       ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
+                                                                     lhs' rhs',
                  fv_lhs' `plusFV` fv_rhs') } }
   where
-    get_var (L _ (RuleBndrSig v _)) = v
-    get_var (L _ (RuleBndr v)) = v
+    get_var (L _ (RuleBndrSig _ v _)) = v
+    get_var (L _ (RuleBndr _ v)) = v
+    get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
 
 bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
                -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
@@ -1010,14 +1012,14 @@ bindHsRuleVars rule_name vars names thing_inside
   where
     doc = RuleCtx rule_name
 
-    go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
+    go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
       = go vars ns $ \ vars' ->
-        thing_inside (L l (RuleBndr (L loc n)) : vars')
+        thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
 
-    go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
+    go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
       = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
-        thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
+        thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
 
     go [] [] thing_inside = thing_inside []
     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
@@ -1057,10 +1059,11 @@ validRuleLhs foralls lhs
   where
     checkl (L _ e) = check e
 
-    check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
-    check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
-    check (HsAppType e _)                 = checkl e
-    check (HsVar (L _ v)) | v `notElem` foralls = Nothing
+    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
+                                                      `mplus` checkl_e e2
+    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
+    check (HsAppType _ e)                 = checkl e
+    check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
         -- Check an argument
@@ -1090,64 +1093,14 @@ badRuleVar name var
 badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
 badRuleLhsErr name lhs bad_e
   = sep [text "Rule" <+> pprRuleName name <> colon,
-         nest 4 (vcat [err,
+         nest 2 (vcat [err,
                        text "in left-hand side:" <+> ppr lhs])]
     $$
     text "LHS must be of form (f e1 .. en) where f is not forall'd"
   where
     err = case bad_e of
-            HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
-            _ -> text "Illegal expression:" <+> ppr bad_e
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Vectorisation declarations}
-*                                                      *
-*********************************************************
--}
-
-rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
--- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
---        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
-rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
-  = do { var' <- lookupLocatedOccRn var
-       ; (rhs', fv_rhs) <- rnLExpr rhs
-       ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
-       }
-rnHsVectDecl (HsVect _ _var _rhs)
-  = failWith $ vcat
-               [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
-               , text "must be an identifier"
-               ]
-rnHsVectDecl (HsNoVect s var)
-  = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
-       ; return (HsNoVect s var', unitFV (unLoc var'))
-       }
-rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
-  = do { tycon' <- lookupLocatedOccRn tycon
-       ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
-       }
-rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
-  = do { tycon'     <- lookupLocatedOccRn tycon
-       ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
-       ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
-                , mkFVs [unLoc tycon', unLoc rhs_tycon'])
-       }
-rnHsVectDecl (HsVectTypeOut _ _ _)
-  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
-rnHsVectDecl (HsVectClassIn s cls)
-  = do { cls' <- lookupLocatedOccRn cls
-       ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
-       }
-rnHsVectDecl (HsVectClassOut _)
-  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
-rnHsVectDecl (HsVectInstIn instTy)
-  = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
-       ; return (HsVectInstIn instTy', fvs)
-       }
-rnHsVectDecl (HsVectInstOut _)
-  = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))
+            _                 -> text "Illegal expression:" <+> ppr bad_e
 
 {- **************************************************************
          *                                                      *
@@ -1301,9 +1254,6 @@ rnTyClDecls tycl_ds
        ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
        ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
 
-       ; tycls_w_fvs <- addBootDeps tycls_w_fvs
-                      -- TBD must add_boot_deps to instds_w_fvs?
-
        -- Do SCC analysis on the type/class decls
        ; rdr_env <- getGlobalRdrEnv
        ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
@@ -1314,7 +1264,8 @@ rnTyClDecls tycl_ds
 
              first_group
                | null init_inst_ds = []
-               | otherwise = [TyClGroup { group_tyclds = []
+               | otherwise = [TyClGroup { group_ext    = noExt
+                                        , group_tyclds = []
                                         , group_roles  = []
                                         , group_instds = init_inst_ds }]
 
@@ -1345,7 +1296,8 @@ rnTyClDecls tycl_ds
         bndrs                = map (tcdName . unLoc) tycl_ds
         (inst_ds, inst_map') = getInsts      bndrs inst_map
         (roles,   role_env') = getRoleAnnots bndrs role_env
-        group = TyClGroup { group_tyclds = tycl_ds
+        group = TyClGroup { group_ext    = noExt
+                          , group_tyclds = tycl_ds
                           , group_roles  = roles
                           , group_instds = inst_ds }
 
@@ -1383,123 +1335,6 @@ getParent rdr_env n
       Nothing -> n
 
 
-{- Note [Extra dependencies from .hs-boot files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This is a long story, so buckle in.
-
-**Dependencies via hs-boot files are not obvious.** Consider the following case:
-
-A.hs-boot
-  module A where
-    data A1
-
-B.hs
-  module B where
-    import {-# SOURCE #-} A
-    type B1 = A1
-
-A.hs
-  module A where
-    import B
-    data A2 = MkA2 B1
-    data A1 = MkA1 A2
-
-Here A2 is really recursive (via B1), but we won't see that easily when
-doing dependency analysis when compiling A.hs.  When we look at A2,
-we see that its free variables are simply B1, but without (recursively) digging
-into the definition of B1 will we see that it actually refers to A1 via an
-hs-boot file.
-
-**Recursive declarations, even those broken by an hs-boot file, need to
-be type-checked together.**  Whenever we refer to a declaration via
-an hs-boot file, we must be careful not to force the TyThing too early:
-ala Note [Tying the knot] if we force the TyThing before we have
-defined it ourselves in the local type environment, GHC will error.
-
-Conservatively, then, it would make sense that we to typecheck A1
-and A2 from the previous example together, because the two types are
-truly mutually recursive through B1.
-
-If we are being clever, we might observe that while kind-checking
-A2, we don't actually need to force the TyThing for A1: B1
-independently records its kind, so there is no need to go "deeper".
-But then we are in an uncomfortable situation where we have
-constructed a TyThing for A2 before we have checked A1, and we
-have to be absolutely certain we don't force it too deeply until
-we get around to kind checking A1, which could be for a very long
-time.
-
-Indeed, with datatype promotion, we may very well need to look
-at the type of MkA2 before we have kind-checked A1: consider,
-
-    data T = MkT (Proxy 'MkA2)
-
-To promote MkA2, we need to lift its type to the kind level.
-We never tested this, but it seems likely A1 would get poked
-at this point.
-
-**Here's what we do instead.**  So it is expedient for us to
-make sure A1 and A2 are kind checked together in a loop.
-To ensure that our dependency analysis can catch this,
-we add a dependency:
-
-  - from every local declaration
-  - to everything that comes from this module's .hs-boot file
-    (this is gotten from sb_tcs in the SelfBootInfo).
-
-In this case, we'll add an edges
-
-  - from A1 to A2 (but that edge is there already)
-  - from A2 to A1 (which is new)
-
-Well, not quite *every* declaration. Imagine module A
-above had another datatype declaration:
-
-  data A3 = A3 Int
-
-Even though A3 has a dependency (on Int), all its dependencies are from things
-that live on other packages. Since we don't have mutual dependencies across
-packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
-
-Hence function nameIsHomePackageImport.
-
-Note that this is fairly conservative: it essentially implies that
-EVERY type declaration in this modules hs-boot file will be kind-checked
-together in one giant loop (and furthermore makes every other type
-in the module depend on this loop).  This is perhaps less than ideal, because
-the larger a recursive group, the less polymorphism available (we
-cannot infer a type to be polymorphically instantiated while we
-are inferring its kind), but no one has hollered about this (yet!)
--}
-
-addBootDeps :: [(LTyClDecl GhcRn, FreeVars)]
-            -> RnM [(LTyClDecl GhcRn, FreeVars)]
--- See Note [Extra dependencies from .hs-boot files]
-addBootDeps ds_w_fvs
-  = do { tcg_env <- getGblEnv
-       ; let this_mod  = tcg_mod tcg_env
-             boot_info = tcg_self_boot tcg_env
-
-             add_boot_deps :: [(LTyClDecl GhcRn, FreeVars)]
-                           -> [(LTyClDecl GhcRn, FreeVars)]
-             add_boot_deps ds_w_fvs
-               = case boot_info of
-                     SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
-                        -> map (add_one tcs) ds_w_fvs
-                     _  -> ds_w_fvs
-
-             add_one :: NameSet -> (LTyClDecl GhcRn, FreeVars)
-                     -> (LTyClDecl GhcRn, FreeVars)
-             add_one tcs pr@(decl,fvs)
-                | has_local_imports fvs = (decl, fvs `plusFV` tcs)
-                | otherwise             = pr
-
-             has_local_imports fvs
-                 = nameSetAny (nameIsHomePackageImport this_mod) fvs
-       ; return (add_boot_deps ds_w_fvs) }
-
-
-
 {- ******************************************************
 *                                                       *
        Role annotations
@@ -1522,24 +1357,24 @@ rnRoleAnnots tc_names role_annots
        ; mapM_ dupRoleAnnotErr dup_annots
        ; mapM (wrapLocM rn_role_annot1) no_dups }
   where
-    rn_role_annot1 (RoleAnnotDecl tycon roles)
+    rn_role_annot1 (RoleAnnotDecl _ tycon roles)
       = do {  -- the name is an *occurrence*, but look it up only in the
               -- decls defined in this group (see #10263)
              tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
                                           (text "role annotation")
                                           tycon
-           ; return $ RoleAnnotDecl tycon' roles }
+           ; return $ RoleAnnotDecl noExt tycon' roles }
+    rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"
 
-dupRoleAnnotErr :: [LRoleAnnotDecl GhcPs] -> RnM ()
-dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
+dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
 dupRoleAnnotErr list
   = addErrAt loc $
     hang (text "Duplicate role annotations for" <+>
           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
-       2 (vcat $ map pp_role_annot sorted_list)
+       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
     where
-      sorted_list = sortBy cmp_annot list
-      (L loc first_decl : _) = sorted_list
+      sorted_list = NE.sortBy cmp_annot list
+      (L loc first_decl :| _) = sorted_list
 
       pp_role_annot (L loc decl) = hang (ppr decl)
                                       4 (text "-- written at" <+> ppr loc)
@@ -1647,21 +1482,19 @@ rnTyClDecl :: TyClDecl GhcPs
 -- in a class decl
 rnTyClDecl (FamDecl { tcdFam = decl })
   = do { (decl', fvs) <- rnFamDecl Nothing decl
-       ; return (FamDecl decl', fvs) }
+       ; return (FamDecl noExt decl', fvs) }
 
 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
                       tcdFixity = fixity, tcdRhs = rhs })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
+       ; kvs <- extractHsTyRdrTyVarsKindVars rhs
        ; let doc = TySynCtx tycon
        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
-       ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
-                                    \ tyvars' _ ->
-                                    do { (rhs', fvs) <- rnTySyn doc rhs
-                                       ; return ((tyvars', rhs'), fvs) }
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
+    do { (rhs', fvs) <- rnTySyn doc rhs
        ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
                          , tcdFixity = fixity
-                         , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
+                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
 
 -- "data", "newtype" declarations
 -- both top level and (for an associated type) in an instance decl
@@ -1671,20 +1504,18 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
        ; kvs <- extractDataDefnKindVars defn
        ; let doc = TyDataCtx tycon
        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
-       ; ((tyvars', defn', no_kvs), fvs)
-           <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
-              do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
-                 ; let sig_tvs         = filterNameSet isTyVarName kind_sig_fvs
-                       unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
-                 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
+    do { (defn', fvs) <- rnDataDefn doc defn
           -- See Note [Complete user-supplied kind signatures] in HsDecls
-       ; typeintype <- xoptM LangExt.TypeInType
-       ; let cusk = hsTvbAllKinded tyvars' &&
-                    (not typeintype || no_kvs)
-       ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
-                          , tcdFixity = fixity
-                          , tcdDataDefn = defn', tcdDataCusk = cusk
-                          , tcdFVs = fvs }, fvs) }
+       ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs
+             rn_info = DataDeclRn { tcdDataCusk = cusk
+                                  , tcdFVs      = fvs }
+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
+       ; return (DataDecl { tcdLName    = tycon'
+                          , tcdTyVars   = tyvars'
+                          , tcdFixity   = fixity
+                          , tcdDataDefn = defn'
+                          , tcdDExt     = rn_info }, fvs) } }
 
 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
                         tcdTyVars = tyvars, tcdFixity = fixity,
@@ -1715,7 +1546,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
 
         -- Check the signatures
         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
-        ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+        ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs
                                          , op <- ops]
         ; checkDupRdrNames sig_rdr_names_w_locs
                 -- Typechecker is responsible for checking that we only
@@ -1745,19 +1576,19 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
                               tcdTyVars = tyvars', tcdFixity = fixity,
                               tcdFDs = fds', tcdSigs = sigs',
                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
-                              tcdDocs = docs', tcdFVs = all_fvs },
+                              tcdDocs = docs', tcdCExt = all_fvs },
                   all_fvs ) }
   where
     cls_doc  = ClassDeclCtx lcls
 
+rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
+
 -- "type" and "type instance" declarations
 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
 rnTySyn doc rhs = rnLHsType doc rhs
 
 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
-           -> RnM ((HsDataDefn GhcRn, NameSet), FreeVars)
-                -- the NameSet includes all Names free in the kind signature
-                -- See Note [Complete user-supplied kind signatures]
+           -> RnM (HsDataDefn GhcRn, FreeVars)
 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                            , dd_ctxt = context, dd_cons = condecls
                            , dd_kindSig = m_sig, dd_derivs = derivs })
@@ -1782,11 +1613,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
 
         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
                         con_fvs `plusFV` sig_fvs
-        ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
-                               , dd_ctxt = context', dd_kindSig = m_sig'
-                               , dd_cons = condecls'
-                               , dd_derivs = derivs' }
-                  , sig_fvs )
+        ; return ( HsDataDefn { dd_ext = noExt
+                              , dd_ND = new_or_data, dd_cType = cType
+                              , dd_ctxt = context', dd_kindSig = m_sig'
+                              , dd_cons = condecls'
+                              , dd_derivs = derivs' }
                  , all_fvs )
         }
   where
@@ -1798,30 +1629,148 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
       = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
            ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
                multipleDerivClausesErr
-           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
            ; return (L loc ds', fvs) }
+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
 
-rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
+rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
                     -> RnM (LHsDerivingClause GhcRn, FreeVars)
-rnLHsDerivingClause deriv_strats_ok doc
-                (L loc (HsDerivingClause { deriv_clause_strategy = dcs
+rnLHsDerivingClause doc
+                (L loc (HsDerivingClause { deriv_clause_ext = noExt
+                                         , deriv_clause_strategy = dcs
                                          , deriv_clause_tys = L loc' dct }))
-  = do { failIfTc (isJust dcs && not deriv_strats_ok) $
-           illegalDerivStrategyErr $ fmap unLoc dcs
-       ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
-       ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
-                                          , deriv_clause_tys = L loc' dct' })
-                , fvs ) }
+  = do { (dcs', dct', fvs)
+           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
+              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
+       ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExt
+                                        , deriv_clause_strategy = dcs'
+                                        , deriv_clause_tys = L loc' dct' })
+              , fvs ) }
+  where
+    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
+                -> RnM (LHsSigType GhcRn, FreeVars)
+    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = L loc _}) =
+      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
+      rnHsSigType doc deriv_ty
+    rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"
+rnLHsDerivingClause _ (L _ (XHsDerivingClause _))
+  = panic "rnLHsDerivingClause"
+
+rnLDerivStrategy :: forall a.
+                    HsDocContext
+                 -> Maybe (LDerivStrategy GhcPs)
+                 -> ([Name]   -- The tyvars bound by the via type
+                      -> SDoc -- The pretty-printed via type (used for
+                              -- error message reporting)
+                      -> RnM (a, FreeVars))
+                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
+rnLDerivStrategy doc mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
+                    pure (Just ds', thing, fvs)
+  where
+    rn_deriv_strat :: LDerivStrategy GhcPs
+                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)
+    rn_deriv_strat (L loc ds) = do
+      let extNeeded :: LangExt.Extension
+          extNeeded
+            | ViaStrategy{} <- ds
+            = LangExt.DerivingVia
+            | otherwise
+            = LangExt.DerivingStrategies
+
+      unlessXOptM extNeeded $
+        failWith $ illegalDerivStrategyErr ds
+
+      case ds of
+        StockStrategy    -> boring_case (L loc StockStrategy)
+        AnyclassStrategy -> boring_case (L loc AnyclassStrategy)
+        NewtypeStrategy  -> boring_case (L loc NewtypeStrategy)
+        ViaStrategy via_ty ->
+          do (via_ty', fvs1) <- rnHsSigType doc via_ty
+             let HsIB { hsib_ext  = via_imp_tvs
+                      , hsib_body = via_body } = via_ty'
+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
+                 via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
+                 via_tvs = via_imp_tvs ++ via_exp_tvs
+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
+                              thing_inside via_tvs (ppr via_ty')
+             pure (L loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
+
+    boring_case :: mds
+                -> RnM (mds, a, FreeVars)
+    boring_case mds = do
+      (thing, fvs) <- thing_inside [] empty
+      pure (mds, thing, fvs)
+
+-- | Errors if a @via@ type binds any floating type variables.
+-- See @Note [Floating `via` type variables]@
+rnAndReportFloatingViaTvs
+  :: forall a. Outputable a
+  => [Name]  -- ^ The bound type variables from a @via@ type.
+  -> SrcSpan -- ^ The source span (for error reporting only).
+  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).
+  -> String  -- ^ A description of what the @via@ type scopes over
+             --   (for error reporting only).
+  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
+  -> RnM (a, FreeVars)
+rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
+  = do (thing, thing_fvs) <- thing_inside
+       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
+       pure (thing, thing_fvs)
+  where
+    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
+    report_floating_via_tv thing used_names tv_name
+      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
+          [ text "Type variable" <+> quotes (ppr tv_name) <+>
+            text "is bound in the" <+> quotes (text "via") <+>
+            text "type" <+> quotes ppr_via_ty
+          , text "but is not mentioned in the derived" <+>
+            text via_scope_desc <+> quotes (ppr thing) <>
+            text ", which is illegal" ]
+
+{-
+Note [Floating `via` type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine the following `deriving via` clause:
+
+    data Quux
+      deriving Eq via (Const a Quux)
+
+This should be rejected. Why? Because it would generate the following instance:
+
+    instance Eq Quux where
+      (==) = coerce @(Quux         -> Quux         -> Bool)
+                    @(Const a Quux -> Const a Quux -> Bool)
+                    (==) :: Const a Quux -> Const a Quux -> Bool
+
+This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
+problem is that `a` is never used anywhere in the derived class `Eq`. Since
+`a` is bound but has no use sites, we refer to it as "floating".
+
+We use the rnAndReportFloatingViaTvs function to check that any type renamed
+within the context of the `via` deriving strategy actually uses all bound
+`via` type variables, and if it doesn't, it throws an error.
+-}
 
 badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _
   = vcat [text "No context is allowed on a GADT-style data declaration",
           text "(You can put a context on each constructor, though.)"]
 
-illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
+illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
 illegalDerivStrategyErr ds
-  = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
-         , text "Use DerivingStrategies to enable this extension" ]
+  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
+         , text enableStrategy ]
+
+  where
+    enableStrategy :: String
+    enableStrategy
+      | ViaStrategy{} <- ds
+      = "Use DerivingVia to enable this extension"
+      | otherwise
+      = "Use DerivingStrategies to enable this extension"
 
 multipleDerivClausesErr :: SDoc
 multipleDerivClausesErr
@@ -1840,15 +1789,15 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; kvs <- extractRdrKindSigVars res_sig
        ; ((tyvars', res_sig', injectivity'), fv1) <-
-            bindHsQTyVars doc Nothing mb_cls kvs tyvars $
-            \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
-            do { let rn_sig = rnFamResultSig doc rn_kvs
+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
+            do { let rn_sig = rnFamResultSig doc
                ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
                                           injectivity
                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
        ; (info', fv2) <- rn_info info
-       ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
+       ; return (FamilyDecl { fdExt = noExt
+                            , fdLName = tycon', fdTyVars = tyvars'
                             , fdFixity = fixity
                             , fdInfo = info', fdResultSig = res_sig'
                             , fdInjectivityAnn = injectivity' }
@@ -1865,17 +1814,17 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
        = return (ClosedTypeFamily Nothing, emptyFVs)
      rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
      rn_info DataFamily     = return (DataFamily, emptyFVs)
+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
 
 rnFamResultSig :: HsDocContext
-               -> [Name]   -- kind variables already in scope
                -> FamilyResultSig GhcPs
                -> RnM (FamilyResultSig GhcRn, FreeVars)
-rnFamResultSig _ _ NoSig
-   = return (NoSig, emptyFVs)
-rnFamResultSig doc _ (KindSig kind)
+rnFamResultSig _ (NoSig _)
+   = return (NoSig noExt, emptyFVs)
+rnFamResultSig doc (KindSig _ kind)
    = do { (rndKind, ftvs) <- rnLHsKind doc kind
-        ;  return (KindSig rndKind, ftvs) }
-rnFamResultSig doc kv_names (TyVarSig tvbndr)
+        ;  return (KindSig noExt rndKind, ftvs) }
+rnFamResultSig doc (TyVarSig _ tvbndr)
    = do { -- `TyVarSig` tells us that user named the result of a type family by
           -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
           -- be sure that the supplied result name is not identical to an
@@ -1893,13 +1842,11 @@ rnFamResultSig doc kv_names (TyVarSig tvbndr)
                            ] $$
                       text "shadows an already bound type variable")
 
-       ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
+       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
                                       -- scoping checks that are irrelevant here
-                          (mkNameSet kv_names) emptyNameSet
-                                       -- use of emptyNameSet here avoids
-                                       -- redundant duplicate errors
-                          tvbndr $ \ _ _ tvbndr' ->
-         return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
+                          tvbndr $ \ tvbndr' ->
+         return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
 
 -- Note [Renaming injectivity annotation]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1940,7 +1887,7 @@ rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in
                  -> LFamilyResultSig GhcRn     -- ^ Result signature
                  -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation
                  -> RnM (LInjectivityAnn GhcRn)
-rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
+rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
                  (L srcSpan (InjectivityAnn injFrom injTo))
  = do
    { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
@@ -2016,6 +1963,7 @@ are no data constructors we allow h98_style = True
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
   = addErr (hang (text "The RHS of an associated type declaration mentions"
+                  <+> text "out-of-scope variable" <> plural ns
                   <+> pprWithCommas (quotes . ppr) ns)
                2 (text "All such variables must be bound on the LHS"))
 
@@ -2024,61 +1972,101 @@ rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
 
 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
-rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
-                           , con_cxt = mcxt, con_details = details
+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                           , con_mb_cxt = mcxt, con_args = args
                            , con_doc = mb_doc })
-  = do  { _ <- addLocM checkConName name
-        ; new_name     <- lookupLocatedTopBndrRn name
-        ; let doc = ConDeclCtx [new_name]
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-        ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
-
-        ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
-          \new_tyvars _ -> do
-        { (new_context, fvs1) <- case mcxt of
-                             Nothing   -> return (Nothing,emptyFVs)
-                             Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
-                                             ; return (Just lctx',fvs) }
-        ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
-        ; let (new_details',fvs3) = (new_details,emptyFVs)
+  = do  { _        <- addLocM checkConName name
+        ; new_name <- lookupLocatedTopBndrRn name
+        ; mb_doc'  <- rnMbLHsDoc mb_doc
+
+        -- We bind no implicit binders here; this is just like
+        -- a nested HsForAllTy.  E.g. consider
+        --         data T a = forall (b::k). MkT (...)
+        -- The 'k' will already be in scope from the bindHsQTyVars
+        -- for the data decl itself. So we'll get
+        --         data T {k} a = ...
+        -- And indeed we may later discover (a::k).  But that's the
+        -- scoping we get.  So no implicit binders at the existential forall
+
+        ; let ctxt = ConDeclCtx [new_name]
+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+                            Nothing ex_tvs $ \ new_ex_tvs ->
+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+        ; let all_fvs  = fvs1 `plusFV` fvs2
         ; traceRn "rnConDecl" (ppr name <+> vcat
-             [ text "free_kvs:" <+> ppr kvs
-             , text "qtvs:" <+> ppr qtvs
-             , text "qtvs':" <+> ppr qtvs' ])
-        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
-              new_tyvars' = case qtvs of
-                Nothing -> Nothing
-                Just _ -> Just new_tyvars
-        ; return (decl { con_name = new_name, con_qvars = new_tyvars'
-                       , con_cxt = new_context, con_details = new_details'
+             [ text "ex_tvs:" <+> ppr ex_tvs
+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
+
+        ; return (decl { con_ext = noExt
+                       , con_name = new_name, con_ex_tvs = new_ex_tvs
+                       , con_mb_cxt = new_context, con_args = new_args
                        , con_doc = mb_doc' },
                   all_fvs) }}
- where
-    cxt = maybe [] unLoc mcxt
-    get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
-
-    get_con_qtvs :: [LHsType GhcPs]
-                 -> RnM ([Located RdrName], LHsQTyVars GhcPs)
-    get_con_qtvs arg_tys
-      | Just tvs <- qtvs   -- data T = forall a. MkT (a -> a)
-      = do { free_vars <- get_rdr_tvs arg_tys
-           ; return (freeKiTyVarsKindVars free_vars, tvs) }
-      | otherwise  -- data T = MkT (a -> a)
-      = return ([], mkHsQTvs [])
-
-rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
+
+rnConDecl decl@(ConDeclGADT { con_names   = names
+                            , con_forall  = L _ explicit_forall
+                            , con_qvars   = qtvs
+                            , con_mb_cxt  = mcxt
+                            , con_args    = args
+                            , con_res_ty  = res_ty
                             , con_doc = mb_doc })
   = do  { mapM_ (addLocM checkConName) names
-        ; new_names    <- mapM lookupLocatedTopBndrRn names
-        ; let doc = ConDeclCtx new_names
-        ; mb_doc'      <- rnMbLHsDoc mb_doc
-
-        ; (ty', fvs) <- rnHsSigType doc ty
-        ; traceRn "rnConDecl" (ppr names <+> vcat
-             [ text "fvs:" <+> ppr fvs ])
-        ; return (decl { con_names = new_names, con_type = ty'
+        ; new_names <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'   <- rnMbLHsDoc mb_doc
+
+        ; let explicit_tkvs = hsQTvExplicit qtvs
+              theta         = hsConDeclTheta mcxt
+              arg_tys       = hsConDeclArgTys args
+
+          -- We must ensure that we extract the free tkvs in left-to-right
+          -- order of their appearance in the constructor type.
+          -- That order governs the order the implicitly-quantified type
+          -- variable, and hence the order needed for visible type application
+          -- See Trac #14808.
+        ; free_tkvs <- extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
+        ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
+
+        ; let ctxt    = ConDeclCtx new_names
+              mb_ctxt = Just (inHsDocContext ctxt)
+
+        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
+        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->
+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+              (args', res_ty')
+                  = case args of
+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)
+                      RecCon {}    -> (new_args, new_res_ty)
+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+                                   -> ASSERT( null as )
+                                      -- See Note [GADT abstract syntax] in HsDecls
+                                      (PrefixCon arg_tys, final_res_ty)
+
+              new_qtvs =  HsQTvs { hsq_ext = HsQTvsRn
+                                     { hsq_implicit  = implicit_tkvs
+                                     , hsq_dependent = emptyNameSet }
+                                 , hsq_explicit  = explicit_tkvs }
+
+        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
+        ; return (decl { con_g_ext = noExt, con_names = new_names
+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+                       , con_args = args', con_res_ty = res_ty'
                        , con_doc = mb_doc' },
-                  fvs) }
+                  all_fvs) } }
+
+rnConDecl (XConDecl _) = panic "rnConDecl"
+
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _    Nothing    = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+                                ; return (Just ctx',fvs) }
 
 rnConDeclDetails
    :: Name
@@ -2120,24 +2108,24 @@ extendPatSynEnv val_decls local_fix_env thing = do {
    ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
   where
     new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
-    new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
+    new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
     new_ps _ = panic "new_ps"
 
     new_ps' :: LHsBindLR GhcPs GhcPs
             -> [(Name, [FieldLabel])]
             -> TcM [(Name, [FieldLabel])]
     new_ps' bind names
-      | L bind_loc (PatSynBind (PSB { psb_id = L _ n
-                                    , psb_args = RecordPatSyn as })) <- bind
+      | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
+                                      , psb_args = RecCon as })) <- bind
       = do
           bnd_name <- newTopSrcBinder (L bind_loc n)
           let rnames = map recordPatSynSelectorId as
               mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
-              mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
+              mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name))
               field_occs =  map mkFieldOcc rnames
           flds     <- mapM (newRecordSelector False [bnd_name]) field_occs
           return ((bnd_name, flds): names)
-      | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
+      | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
       = do
         bnd_name <- newTopSrcBinder (L bind_loc n)
         return ((bnd_name, []): names)
@@ -2152,8 +2140,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
 *********************************************************
 -}
 
-rnFds :: [Located (FunDep (Located RdrName))]
-  -> RnM [Located (FunDep (Located Name))]
+rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
 rnFds fds
   = mapM (wrapLocM rn_fds) fds
   where
@@ -2199,12 +2186,12 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
 
 -- #10047: Declaration QuasiQuoters are expanded immediately, without
 --         causing a group split
-add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
+add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
   = do { (ds', _) <- rnTopSpliceDecls qq
        ; addl gp (ds' ++ ds)
        }
 
-add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
+add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
   = do { -- We've found a top-level splice.  If it is an *implicit* one
          -- (i.e. a naked top level expression)
          case flag of
@@ -2217,84 +2204,98 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
   where
     badImplicitSplice = text "Parse error: module header, import declaration"
                      $$ text "or top-level declaration expected."
+                     -- The compiler should suggest the above, and not using
+                     -- TemplateHaskell since the former suggestion is more
+                     -- relevant to the larger base of users.
+                     -- See Trac #12146 for discussion.
 
 -- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
   | isClassDecl d
-  = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+  = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in
     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
   | otherwise
   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
 
 -- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
   = addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 
 -- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
+add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds
   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 
 -- Role annotations: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
   = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
 
 -- NB instance declarations go into TyClGroups. We throw them into the first
 -- group, just as we do for the TyClD case. The renamer will go on to group
 -- and order them later.
-add gp@(HsGroup {hs_tyclds = ts})  l (InstD d) ds
+add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds
   = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
 
 -- The rest are routine
-add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds
   = addl (gp { hs_derivds = L l d : ts }) ds
-add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
+add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds
   = addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds
   = addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds
   = addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
+add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds
   = addl (gp { hs_annds = L l d : ts }) ds
-add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds
-add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
-  = addl (gp { hs_vects = L l d : ts }) ds
-add gp l (DocD d) ds
+add gp l (DocD _ d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
-
-add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_tycld d []       = [TyClGroup { group_tyclds = [d]
-                                  , group_roles = []
+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
+add (HsGroup {}) _ (XHsDecl _)                 _ = panic "RnSource.add"
+add (XHsGroup _) _ _                           _ = panic "RnSource.add"
+
+add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_tycld d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = [d]
+                                  , group_roles  = []
                                   , group_instds = []
                                   }
                        ]
 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
   = ds { group_tyclds = d : tyclds } : dss
+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
 
-add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_instd d []       = [TyClGroup { group_tyclds = []
-                                  , group_roles = []
+add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_instd d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = []
+                                  , group_roles  = []
                                   , group_instds = [d]
                                   }
                        ]
 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
   = ds { group_instds = d : instds } : dss
+add_instd _ (XTyClGroup _: _) = panic "add_instd"
 
-add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_role_annot d [] = [TyClGroup { group_tyclds = []
-                                 , group_roles = [d]
+add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+               -> [TyClGroup (GhcPass p)]
+add_role_annot d [] = [TyClGroup { group_ext    = noExt
+                                 , group_tyclds = []
+                                 , group_roles  = [d]
                                  , group_instds = []
                                  }
                       ]
 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
   = tycls { group_roles = d : roles } : rest
+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
 
 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
+add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"
 
-add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
-add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
+add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
+add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index a03e4c88df..19bf763f63 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -11,12 +11,13 @@ module RnSplice (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Name
 import NameSet
 import HsSyn
 import RdrName
 import TcRnMonad
-import Kind
 
 import RnEnv
 import RnUtils          ( HsDocContext(..), newLocalBndrRn )
@@ -101,7 +102,7 @@ rnBracket e br_body
                         ; (body', fvs_e) <-
                           setStage (Brack cur_stage RnPendingTyped) $
                                    rn_bracket cur_stage br_body
-                        ; return (HsBracket body', fvs_e) }
+                        ; return (HsBracket noExt body', fvs_e) }
 
             False -> do { traceRn "Renaming untyped TH bracket" empty
                         ; ps_var <- newMutVar []
@@ -109,11 +110,11 @@ rnBracket e br_body
                           setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
                                    rn_bracket cur_stage br_body
                         ; pendings <- readMutVar ps_var
-                        ; return (HsRnBracketOut body' pendings, fvs_e) }
+                        ; return (HsRnBracketOut noExt body' pendings, fvs_e) }
        }
 
 rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
-rn_bracket outer_stage br@(VarBr flg rdr_name)
+rn_bracket outer_stage br@(VarBr x flg rdr_name)
   = do { name <- lookupOccRn rdr_name
        ; this_mod <- getModule
 
@@ -135,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
                                              (quotedNameStageErr br) }
                         }
                     }
-       ; return (VarBr flg name, unitFV name) }
+       ; return (VarBr x flg name, unitFV name) }
 
-rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
-                            ; return (ExpBr e', fvs) }
+rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+                            ; return (ExpBr x e', fvs) }
 
-rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+rn_bracket _ (PatBr x p)
+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
 
-rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
-                            ; return (TypBr t', fvs) }
+rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+                              ; return (TypBr x t', fvs) }
 
-rn_bracket _ (DecBrL decls)
+rn_bracket _ (DecBrL x decls)
   = do { group <- groupDecls decls
        ; gbl_env  <- getGblEnv
        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -157,7 +159,7 @@ rn_bracket _ (DecBrL decls)
               -- Discard the tcg_env; it contains only extra info about fixity
         ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
                    ppr (duUses (tcg_dus tcg_env)))
-        ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
+        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
   where
     groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
     groupDecls decls
@@ -171,10 +173,12 @@ rn_bracket _ (DecBrL decls)
                   }
            }}
 
-rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+                               ; return (TExpBr x e', fvs) }
 
-rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
-                             ; return (TExpBr e', fvs) }
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
 
 quotationCtxtDoc :: HsBracket GhcPs -> SDoc
 quotationCtxtDoc br_body
@@ -292,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice
   = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
 
        ; let the_expr = case splice' of
-                  HsUntypedSplice _ _ e   ->  e
-                  HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
-                  HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)
-                  HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)
+                HsUntypedSplice _ _ _ e   ->  e
+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)
+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)
+                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)
 
              -- Typecheck the expression
        ; meta_exp_ty   <- tcMetaTy meta_ty_name
@@ -333,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice
 makePending :: UntypedSpliceFlavour
             -> HsSplice GhcRn
             -> PendingRnSplice
-makePending flavour (HsUntypedSplice _ n e)
+makePending flavour (HsUntypedSplice _ _ n e)
   = PendingRnSplice flavour n e
-makePending flavour (HsQuasiQuote n quoter q_span quote)
+makePending flavour (HsQuasiQuote _ n quoter q_span quote)
   = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
 makePending _ splice@(HsTypedSplice {})
   = pprPanic "makePending" (ppr splice)
 makePending _ splice@(HsSpliced {})
   = pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+  = pprPanic "makePending" (ppr splice)
 
 ------------------
 mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
@@ -348,13 +355,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
 -- Return the expression (quoter "...quote...")
 -- which is what we must run in a quasi-quote
 mkQuasiQuoteExpr flavour quoter q_span quote
-  = L q_span $ HsApp (L q_span $
-                      HsApp (L q_span (HsVar (L q_span quote_selector)))
+  = L q_span $ HsApp noExt (L q_span $
+                  HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector)))
                             quoterExpr)
                      quoteExpr
   where
-    quoterExpr = L q_span $! HsVar $! (L q_span quoter)
-    quoteExpr  = L q_span $! HsLit $! HsString NoSourceText quote
+    quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter)
+    quoteExpr  = L q_span $! HsLit noExt $! HsString NoSourceText quote
     quote_selector = case flavour of
                        UntypedExpSplice  -> quoteExpName
                        UntypedPatSplice  -> quotePatName
@@ -364,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote
 ---------------------
 rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
 -- Not exported...used for all
-rnSplice (HsTypedSplice hasParen splice_name expr)
+rnSplice (HsTypedSplice x hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell typed splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsTypedSplice hasParen n' expr', fvs) }
+        ; return (HsTypedSplice x hasParen n' expr', fvs) }
 
-rnSplice (HsUntypedSplice hasParen splice_name expr)
+rnSplice (HsUntypedSplice x hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell untyped splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsUntypedSplice hasParen n' expr', fvs) }
+        ; return (HsUntypedSplice x hasParen n' expr', fvs) }
 
-rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
+rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
   = do  { checkTH quoter "Template Haskell quasi-quote"
         ; loc  <- getSrcSpanM
         ; splice_name' <- newLocalBndrRn (L loc splice_name)
@@ -389,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
         ; when (nameIsLocalOrFrom this_mod quoter') $
           checkThLocalName quoter'
 
-        ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
+        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+                                                             , unitFV quoter') }
 
 rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)
 
 ---------------------
 rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
@@ -400,7 +409,7 @@ rnSpliceExpr splice
   where
     pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
     pend_expr_splice rn_splice
-        = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)
+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)
 
     run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
     run_expr_splice rn_splice
@@ -413,7 +422,7 @@ rnSpliceExpr splice
                                                      , isLocalGRE gre]
                  lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
 
-           ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
+           ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }
 
       | otherwise  -- Run it here, see Note [Running splices in the Renamer]
       = do { traceRn "rnSpliceExpr: untyped expression splice" empty
@@ -421,8 +430,8 @@ rnSpliceExpr splice
                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice
            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
              -- See Note [Delaying modFinalizers in untyped splices].
-           ; return ( HsPar $ HsSpliceE
-                            . HsSpliced (ThModFinalizers mod_finalizers)
+           ; return ( HsPar noExt $ HsSpliceE noExt
+                            . HsSpliced noExt (ThModFinalizers mod_finalizers)
                             . HsSplicedExpr <$>
                             lexpr3
                     , fvs)
@@ -519,13 +528,13 @@ References:
 -}
 
 ----------------------
-rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind
-             -> RnM (HsType GhcRn, FreeVars)
-rnSpliceType splice k
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType splice
   = rnSpliceGen run_type_splice pend_type_splice splice
   where
     pend_type_splice rn_splice
-       = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
+       = ( makePending UntypedTypeSplice rn_splice
+         , HsSpliceTy noExt rn_splice)
 
     run_type_splice rn_splice
       = do { traceRn "rnSpliceType: untyped type splice" empty
@@ -535,8 +544,8 @@ rnSpliceType splice k
                                  ; checkNoErrs $ rnLHsType doc hs_ty2 }
                                     -- checkNoErrs: see Note [Renamer errors]
              -- See Note [Delaying modFinalizers in untyped splices].
-           ; return ( HsParTy $ flip HsSpliceTy k
-                              . HsSpliced (ThModFinalizers mod_finalizers)
+           ; return ( HsParTy noExt $ HsSpliceTy noExt
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
                               . HsSplicedTy <$>
                               hs_ty3
                     , fvs
@@ -592,17 +601,18 @@ rnSplicePat splice
   = rnSpliceGen run_pat_splice pend_pat_splice splice
   where
     pend_pat_splice rn_splice
-      = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
+      = (makePending UntypedPatSplice rn_splice
+        , Right (SplicePat noExt rn_splice))
 
     run_pat_splice rn_splice
       = do { traceRn "rnSplicePat: untyped pattern splice" empty
            ; (pat, mod_finalizers) <-
                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice
              -- See Note [Delaying modFinalizers in untyped splices].
-           ; return ( Left $ ParPat $ SplicePat
-                                    . HsSpliced (ThModFinalizers mod_finalizers)
-                                    . HsSplicedPat <$>
-                                    pat
+           ; return ( Left $ ParPat noExt $ (SplicePat noExt)
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedPat <$>
+                              pat
                     , emptyFVs
                     ) }
               -- Wrap the result of the quasi-quoter in parens so that we don't
@@ -610,13 +620,15 @@ rnSplicePat splice
 
 ----------------------
 rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
-rnSpliceDecl (SpliceDecl (L loc splice) flg)
+rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
   = rnSpliceGen run_decl_splice pend_decl_splice splice
   where
     pend_decl_splice rn_splice
-       = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)
+       = ( makePending UntypedDeclSplice rn_splice
+         , SpliceDecl noExt (L loc rn_splice) flg)
 
     run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
 
 rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
 -- Declaration splice at the very top level of the module
@@ -685,6 +697,7 @@ spliceCtxt splice
              HsTypedSplice   {} -> text "typed splice:"
              HsQuasiQuote    {} -> text "quasi-quotation:"
              HsSpliced       {} -> text "spliced expression:"
+             XSplice         {} -> text "spliced expression:"
 
 -- | The splice data to be logged
 data SpliceInfo
diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot
index 875ba05e52..7844acd2c9 100644
--- a/compiler/rename/RnSplice.hs-boot
+++ b/compiler/rename/RnSplice.hs-boot
@@ -1,13 +1,12 @@
 module RnSplice where
 
+import GhcPrelude
 import HsSyn
 import TcRnMonad
 import NameSet
-import Kind
 
 
-rnSpliceType :: HsSplice GhcPs   -> PostTc GhcRn Kind
-             -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)
 rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
                                           , FreeVars )
 rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 014d4850c8..a78caaf6ba 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -23,15 +23,20 @@ module RnTypes (
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        bindLHsTyVarBndr,
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
-        extractFilteredRdrTyVars,
-        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+        extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
+        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
+        extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
         extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
-        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars
+        extractHsTvBndrs,
+        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
+        elemRdr
   ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} RnSplice( rnSpliceType )
 
 import DynFlags
@@ -40,21 +45,21 @@ import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
 import RnEnv
 import RnUnbound        ( perhapsForallMsg )
 import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn
-                        , pprHsDocContext, bindLocalNamesFV, dupNamesErr
-                        , newLocalBndrRn, checkShadowedRdrNames )
+                        , pprHsDocContext, bindLocalNamesFV
+                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
 import RnFixity         ( lookupFieldFixityRn, lookupFixityRn
                         , lookupTyFixityRn )
 import TcRnMonad
 import RdrName
 import PrelNames
 import TysPrim          ( funTyConName )
-import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )
 import Name
 import SrcLoc
 import NameSet
 import FieldLabel
 
 import Util
+import ListSetOps       ( deleteBys )
 import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                           Fixity(..), FixityDirection(..), LexicalFixity(..) )
 import Outputable
@@ -62,8 +67,8 @@ import FastString
 import Maybes
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.List        ( nubBy, partition )
-import Control.Monad    ( unless, when )
+import Data.List          ( nubBy, partition, (\\) )
+import Control.Monad      ( unless, when )
 
 #include "HsVersions.h"
 
@@ -81,7 +86,7 @@ to break several loop.
 rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
             -> RnM (LHsSigWcType GhcRn, FreeVars)
 rnHsSigWcType doc sig_ty
-  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
+  = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
     return (sig_ty', emptyFVs)
 
 rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
@@ -95,38 +100,50 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
 rnHsSigWcTypeScoped ctx sig_ty thing_inside
   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
        ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
-       ; rn_hs_sig_wc_type False ctx sig_ty thing_inside
+       ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
        }
-    -- False: for pattern type sigs and rules we /do/ want
-    --        to bring those type variables into scope
+    -- True: for pattern type sigs and rules we /do/ want
+    --       to bring those type variables into scope, even
+    --       if there's a forall at the top which usually
+    --       stops that happening
     -- e.g  \ (x :: forall a. a-> b) -> e
     -- Here we do bring 'b' into scope
 
-rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
+rn_hs_sig_wc_type :: Bool   -- True <=> always bind any free tyvars of the
+                            --          type, regardless of whether it has
+                            --          a forall at the top
                   -> HsDocContext
                   -> LHsSigWcType GhcPs
                   -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type no_implicit_if_forall ctxt
+rn_hs_sig_wc_type always_bind_free_tvs ctxt
                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                   thing_inside
-  = do { free_vars <- extractFilteredRdrTyVars hs_ty
-       ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
-       ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->
+  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
+       ; let nwc_rdrs = nubL nwc_rdrs'
+             bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
-       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
-             ib_ty'  = mk_implicit_bndrs vars hs_ty' fvs1
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
+             ib_ty'  = HsIB { hsib_ext = vars
+                            , hsib_body = hs_ty' }
        ; (res, fvs2) <- thing_inside sig_ty'
        ; return (res, fvs1 `plusFV` fvs2) } }
+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
+  = panic "rn_hs_sig_wc_type"
+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
+  = panic "rn_hs_sig_wc_type"
 
 rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
 rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
   = do { free_vars <- extractFilteredRdrTyVars hs_ty
        ; (_, nwc_rdrs) <- partition_nwcs free_vars
        ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
-       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
        ; return (sig_ty', fvs) }
+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
 
 rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
          -> RnM ([Name], LHsType GhcRn, FreeVars)
@@ -149,27 +166,29 @@ rnWcBody ctxt nwc_rdrs hs_ty
     rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
     -- A lot of faff just to allow the extra-constraints wildcard to appear
     rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
-      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
-                           Nothing [] tvs $ \ _ tvs' _ _ ->
+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
         do { (hs_body', fvs) <- rn_lty env hs_body
-           ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }
+           ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
+                                , hst_body = hs_body' }, fvs) }
 
     rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
       | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
-      , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
+      , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last
       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
            ; wc' <- setSrcSpan lx $
-                    do { checkExtraConstraintWildCard env wc
-                       ; rnAnonWildCard wc }
+                    do { checkExtraConstraintWildCard env hs_ctxt1
+                       ; rnAnonWildCard }
            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
-           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
                     , fvs1 `plusFV` fvs2) }
 
       | otherwise
       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
-           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
                     , fvs1 `plusFV` fvs2) }
 
     rn_ty env hs_ty = rnHsTyKi env hs_ty
@@ -177,26 +196,45 @@ rnWcBody ctxt nwc_rdrs hs_ty
     rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
 
 
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs
-                             -> RnM ()
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
 -- Rename the extra-constraint spot in a type signature
 --    (blah, _) => type
 -- Check that extra-constraints are allowed at all, and
 -- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env wc
+checkExtraConstraintWildCard env hs_ctxt
   = checkWildCard env mb_bad
   where
     mb_bad | not (extraConstraintWildCardsAllowed env)
-           = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
-                   <+> text "not allowed")
+           = Just base_msg
+             -- Currently, we do not allow wildcards in their full glory in
+             -- standalone deriving declarations. We only allow a single
+             -- extra-constraints wildcard à la:
+             --
+             --   deriving instance _ => Eq (Foo a)
+             --
+             -- i.e., we don't support things like
+             --
+             --   deriving instance (Eq a, _) => Eq (Foo a)
+           | DerivDeclCtx {} <- rtke_ctxt env
+           , not (null hs_ctxt)
+           = Just deriv_decl_msg
            | otherwise
            = Nothing
 
+    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
+                   <+> text "not allowed"
+
+    deriv_decl_msg
+      = hang base_msg
+           2 (vcat [ text "except as the sole constraint"
+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
 extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
 extraConstraintWildCardsAllowed env
   = case rtke_ctxt env of
       TypeSigCtx {}       -> True
       ExprWithTySigCtx {} -> True
+      DerivDeclCtx {}     -> True
       _                   -> False
 
 -- | Finds free type and kind variables in a type,
@@ -204,11 +242,21 @@ extraConstraintWildCardsAllowed env
 --     without variables that are already in scope in LocalRdrEnv
 --   NB: this includes named wildcards, which look like perfectly
 --       ordinary type variables at this point
-extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars
+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
 extractFilteredRdrTyVars hs_ty
   = do { rdr_env <- getLocalRdrEnv
        ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
 
+-- | Finds free type and kind variables in a type,
+--     with duplicates, but
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractFilteredRdrTyVarsDups hs_ty
+  = do { rdr_env <- getLocalRdrEnv
+       ; filterInScope rdr_env <$> extractHsTyRdrTyVarsDups hs_ty }
+
 -- | When the NamedWildCards extension is enabled, partition_nwcs
 -- removes type variables that start with an underscore from the
 -- FreeKiTyVars in the argument and returns them in a separate list.
@@ -249,62 +297,78 @@ rnHsSigType :: HsDocContext -> LHsSigType GhcPs
 -- Used for source-language type signatures
 -- that cannot have wildcards
 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
-  = do { vars <- extractFilteredRdrTyVars hs_ty
-       ; rnImplicitBndrs True vars hs_ty $ \ vars ->
+  = do { traceRn "rnHsSigType" (ppr hs_ty)
+       ; vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
     do { (body', fvs) <- rnLHsType ctx hs_ty
-       ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
+       ; return ( HsIB { hsib_ext = vars
+                       , hsib_body = body' }
+                , fvs ) } }
+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
 
-rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
-                           --          if type is headed by a forall
+rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
                            -- E.g.  f :: forall a. a->b
-                           -- Do not quantify over 'b' too.
-                -> FreeKiTyVars
-                -> LHsType GhcPs
+                           --  we do not want to bring 'b' into scope, hence False
+                           -- But   f :: a -> b
+                           --  we want to bring both 'a' and 'b' into scope
+                -> FreeKiTyVarsWithDups
+                                   -- Free vars of hs_ty (excluding wildcards)
+                                   -- May have duplicates, which is
+                                   -- checked here
                 -> ([Name] -> RnM (a, FreeVars))
                 -> RnM (a, FreeVars)
-rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
-  = do { let real_tv_rdrs  -- Implicit quantification only if
-                           -- there is no explicit forall
-               | no_implicit_if_forall
-               , L _ (HsForAllTy {}) <- hs_ty = []
-               | otherwise                    = freeKiTyVarsTypeVars free_vars
-             real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
-       ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
-                                        ppr real_rdrs)
-
-       ; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$
-                                        ppr real_rdrs)
-       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
+rnImplicitBndrs bind_free_tvs
+                fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
+                                    , fktv_tys = tvs_with_dups })
+                thing_inside
+  = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
+             real_tvs | bind_free_tvs = tvs
+                      | otherwise     = []
+             -- We always bind over free /kind/ variables.
+             -- Bind free /type/ variables only if there is no
+             -- explicit forall.  E.g.
+             --    f :: Proxy (a :: k) -> b
+             --         Quantify over {k} and {a,b}
+             --    g :: forall a. Proxy (a :: k) -> b
+             --         Quantify over {k} and {}
+             -- Note that we always do the implicit kind-quantification
+             -- but, rather arbitrarily, we switch off the type-quantification
+             -- if there is an explicit forall
+
+       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
+
+       ; whenWOptM Opt_WarnImplicitKindVars $
+         unless (bind_free_tvs || null kvs) $
+         addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $
+         implicit_kind_vars_msg kvs
+
+       ; loc <- getSrcSpanM
+          -- NB: kinds before tvs, as mandated by
+          -- Note [Ordering of implicit variables]
+       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
+
+       ; traceRn "checkMixedVars2" $
+           vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
+                , text "tvs_with_dups" <+> ppr tvs_with_dups ]
+
        ; bindLocalNamesFV vars $
          thing_inside vars }
+  where
+    implicit_kind_vars_msg kvs =
+      vcat [ text "An explicit" <+> quotes (text "forall") <+>
+             text "was used, but the following kind variables" <+>
+             text "are not quantified:" <+>
+             hsep (punctuate comma (map (quotes . ppr) kvs))
+           , text "Despite this fact, GHC will introduce them into scope," <+>
+             text "but it will stop doing so in the future."
+           , text "Suggested fix: add" <+>
+             quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
 
 rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance or standalone deriving decl
--- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
-rnLHsInstType doc_str inst_ty
-  | Just cls <- getLHsInstDeclClass_maybe inst_ty
-  , isTcOcc (rdrNameOcc (unLoc cls))
-         -- The guards check that the instance type looks like
-         --   blah => C ty1 .. tyn
-  = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls)
-       ; rnHsSigType (GenericCtx full_doc) inst_ty }
-
-  | otherwise  -- The instance is malformed, but we'd still like
-               -- to make progress rather than failing outright, so
-               -- we report more errors.  So we rename it anyway.
-  = do { addErrAt (getLoc (hsSigType inst_ty)) $
-         text "Malformed instance:" <+> ppr inst_ty
-       ; rnHsSigType (GenericCtx doc_str) inst_ty }
-
-mk_implicit_bndrs :: [Name]  -- implicitly bound
-                  -> a           -- payload
-                  -> FreeVars    -- FreeVars of payload
-                  -> HsImplicitBndrs GhcRn a
-mk_implicit_bndrs vars body fvs
-  = HsIB { hsib_vars = vars
-         , hsib_body = body
-         , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
-
+-- Rename the type in an instance.
+-- The 'doc_str' is "an instance declaration".
+-- Do not try to decompose the inst_ty in case it is malformed
+rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
 
 {- ******************************************************
 *                                                       *
@@ -335,35 +399,6 @@ f :: forall a. a -> (() => b) binds "a" and "b"
 This situation is now considered to be an error. See rnHsTyKi for case
 HsForAllTy Qualified.
 
-Note [Dealing with *]
-~~~~~~~~~~~~~~~~~~~~~
-As a legacy from the days when types and kinds were different, we use
-the type * to mean what we now call GHC.Types.Type. The problem is that
-* should associate just like an identifier, *not* a symbol.
-Running example: the user has written
-
-  T (Int, Bool) b + c * d
-
-At this point, we have a bunch of stretches of types
-
-  [[T, (Int, Bool), b], [c], [d]]
-
-these are the [[LHsType Name]] and a bunch of operators
-
-  [GHC.TypeLits.+, GHC.Types.*]
-
-Note that the * is GHC.Types.*. So, we want to rearrange to have
-
-  [[T, (Int, Bool), b], [c, *, d]]
-
-and
-
-  [GHC.TypeLits.+]
-
-as our lists. We can then do normal fixity resolution on these. The fixities
-must come along for the ride just so that the list stays in sync with the
-operators.
-
 Note [QualTy in kinds]
 ~~~~~~~~~~~~~~~~~~~~~~
 I was wondering whether QualTy could occur only at TypeLevel.  But no,
@@ -465,47 +500,56 @@ rnLHsTyKi env (L loc ty)
 rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
 
 rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
-  = do { checkTypeInType env ty
+  = do { checkPolyKinds env ty
        ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
-                           Nothing [] tyvars $ \ _ tyvars' _ _ ->
+                           Nothing tyvars $ \ tyvars' ->
     do { (tau',  fvs) <- rnLHsTyKi env tau
-       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
+       ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
+                             , hst_body =  tau' }
                 , fvs) } }
 
 rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
-  = do { checkTypeInType env ty  -- See Note [QualTy in kinds]
+  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]
        ; (ctxt', fvs1) <- rnTyKiContext env lctxt
        ; (tau',  fvs2) <- rnLHsTyKi env tau
-       ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
+       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+                          , hst_body =  tau' }
                 , fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env (HsTyVar ip (L loc rdr_name))
-  = do { name <- rnTyVar env rdr_name
-       ; return (HsTyVar ip (L loc name), unitFV name) }
-
-rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
+rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
+  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
+         unlessXOptM LangExt.PolyKinds $ addErr $
+         withHsDocContext (rtke_ctxt env) $
+         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
+              , text "Perhaps you intended to use PolyKinds" ]
+           -- Any type variable at the kind level is illegal without the use
+           -- of PolyKinds (see #14710)
+       ; name <- rnTyVar env rdr_name
+       ; return (HsTyVar noExt ip (L loc name), unitFV name) }
+
+rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
   = setSrcSpan (getLoc l_op) $
     do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
         ; fix   <- lookupTyFixityRn l_op'
         ; (ty1', fvs2) <- rnLHsTyKi env ty1
         ; (ty2', fvs3) <- rnLHsTyKi env ty2
-        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
                                (unLoc l_op') fix ty1' ty2'
         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
 
-rnHsTyKi env (HsParTy ty)
+rnHsTyKi env (HsParTy _ ty)
   = do { (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsParTy ty', fvs) }
+       ; return (HsParTy noExt ty', fvs) }
 
-rnHsTyKi env (HsBangTy b ty)
+rnHsTyKi env (HsBangTy _ b ty)
   = do { (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsBangTy b ty', fvs) }
+       ; return (HsBangTy noExt b ty', fvs) }
 
-rnHsTyKi env ty@(HsRecTy flds)
+rnHsTyKi env ty@(HsRecTy _ flds)
   = do { let ctxt = rtke_ctxt env
        ; fls          <- get_fields ctxt
        ; (flds', fvs) <- rnConDeclFields ctxt fls flds
-       ; return (HsRecTy flds', fvs) }
+       ; return (HsRecTy noExt flds', fvs) }
   where
     get_fields (ConDeclCtx names)
       = concatMapM (lookupConstructorFields . unLoc) names
@@ -514,7 +558,7 @@ rnHsTyKi env ty@(HsRecTy flds)
                                    2 (ppr ty))
            ; return [] }
 
-rnHsTyKi env (HsFunTy ty1 ty2)
+rnHsTyKi env (HsFunTy _ ty1 ty2)
   = do { (ty1', fvs1) <- rnLHsTyKi env ty1
         -- Might find a for-all as the arg of a function type
        ; (ty2', fvs2) <- rnLHsTyKi env ty2
@@ -522,160 +566,95 @@ rnHsTyKi env (HsFunTy ty1 ty2)
         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 
         -- Check for fixity rearrangements
-       ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
        ; return (res_ty, fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env listTy@(HsListTy ty)
+rnHsTyKi env listTy@(HsListTy _ ty)
   = do { data_kinds <- xoptM LangExt.DataKinds
        ; when (not data_kinds && isRnKindLevel env)
               (addErr (dataKindsErr env listTy))
        ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsListTy ty', fvs) }
+       ; return (HsListTy noExt ty', fvs) }
 
-rnHsTyKi env t@(HsKindSig ty k)
-  = do { checkTypeInType env t
+rnHsTyKi env t@(HsKindSig _ ty k)
+  = do { checkPolyKinds env t
        ; kind_sigs_ok <- xoptM LangExt.KindSignatures
        ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
        ; (ty', fvs1) <- rnLHsTyKi env ty
        ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
-       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
-
-rnHsTyKi env t@(HsPArrTy ty)
-  = do { notInKinds env t
-       ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsPArrTy ty', fvs) }
+       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)
+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
   = do { data_kinds <- xoptM LangExt.DataKinds
        ; when (not data_kinds && isRnKindLevel env)
               (addErr (dataKindsErr env tupleTy))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsTupleTy tup_con tys', fvs) }
+       ; return (HsTupleTy noExt tup_con tys', fvs) }
 
-rnHsTyKi env sumTy@(HsSumTy tys)
+rnHsTyKi env sumTy@(HsSumTy _ tys)
   = do { data_kinds <- xoptM LangExt.DataKinds
        ; when (not data_kinds && isRnKindLevel env)
               (addErr (dataKindsErr env sumTy))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsSumTy tys', fvs) }
+       ; return (HsSumTy noExt tys', fvs) }
 
 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi env tyLit@(HsTyLit t)
+rnHsTyKi env tyLit@(HsTyLit _ t)
   = do { data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env tyLit))
        ; when (negLit t) (addErr negLitErr)
-       ; checkTypeInType env tyLit
-       ; return (HsTyLit t, emptyFVs) }
+       ; checkPolyKinds env tyLit
+       ; return (HsTyLit noExt t, emptyFVs) }
   where
     negLit (HsStrTy _ _) = False
     negLit (HsNumTy _ i) = i < 0
     negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
 
-rnHsTyKi env overall_ty@(HsAppsTy tys)
-  = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
-         let (non_syms, syms) = splitHsAppsTy tys
-
-             -- Step 2: rename the pieces
-       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp env overall_ty) syms
-       ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
-
-             -- Step 3: deal with *. See Note [Dealing with *]
-       ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
-
-             -- Step 4: collapse the non-symbol regions with HsAppTy
-       ; non_syms3 <- mapM deal_with_non_syms non_syms2
-
-             -- Step 5: assemble the pieces, using mkHsOpTyRn
-       ; L _ res_ty <- build_res_ty non_syms3 syms2
-
-        -- all done. Phew.
-       ; return (res_ty, fvs1 `plusFV` fvs2) }
-  where
-    -- See Note [Dealing with *]
-    deal_with_star :: [[LHsType GhcRn]] -> [Located Name]
-                   -> [[LHsType GhcRn]] -> [Located Name]
-                   -> ([[LHsType GhcRn]], [Located Name])
-    deal_with_star acc1 acc2
-                   (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
-      | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
-      = deal_with_star acc1 acc2
-                       ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
-                            : non_syms2) : non_syms)
-                       ops
-    deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
-      = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
-    deal_with_star acc1 acc2 [non_syms] []
-      = (reverse (non_syms : acc1), reverse acc2)
-    deal_with_star _ _ _ _
-      = pprPanic "deal_with_star" (ppr overall_ty)
-
-    -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications
-    -- monadic only for failure
-    deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn)
-    deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
-    deal_with_non_syms []                   = failWith (emptyNonSymsErr overall_ty)
-
-    -- assemble a right-biased OpTy for use in mkHsOpTyRn
-    build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn)
-    build_res_ty (arg1 : args) (op1 : ops)
-      = do { rhs <- build_res_ty args ops
-           ; fix <- lookupTyFixityRn op1
-           ; res <-
-               mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
-           ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
-           ; return (L loc res)
-           }
-    build_res_ty [arg] [] = return arg
-    build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
-
-rnHsTyKi env (HsAppTy ty1 ty2)
+rnHsTyKi env (HsAppTy _ ty1 ty2)
   = do { (ty1', fvs1) <- rnLHsTyKi env ty1
        ; (ty2', fvs2) <- rnLHsTyKi env ty2
-       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env t@(HsIParamTy n ty)
+rnHsTyKi env t@(HsIParamTy _ n ty)
   = do { notInKinds env t
        ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsIParamTy n ty', fvs) }
+       ; return (HsIParamTy noExt n ty', fvs) }
 
-rnHsTyKi env t@(HsEqTy ty1 ty2)
-  = do { checkTypeInType env t
-       ; (ty1', fvs1) <- rnLHsTyKi env ty1
-       ; (ty2', fvs2) <- rnLHsTyKi env ty2
-       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
+rnHsTyKi _ (HsStarTy _ isUni)
+  = return (HsStarTy noExt isUni, emptyFVs)
 
-rnHsTyKi _ (HsSpliceTy sp k)
-  = rnSpliceType sp k
+rnHsTyKi _ (HsSpliceTy _ sp)
+  = rnSpliceType sp
 
-rnHsTyKi env (HsDocTy ty haddock_doc)
+rnHsTyKi env (HsDocTy _ ty haddock_doc)
   = do { (ty', fvs) <- rnLHsTyKi env ty
        ; haddock_doc' <- rnLHsDoc haddock_doc
-       ; return (HsDocTy ty' haddock_doc', fvs) }
+       ; return (HsDocTy noExt ty' haddock_doc', fvs) }
 
-rnHsTyKi _ (HsCoreTy ty)
-  = return (HsCoreTy ty, emptyFVs)
+rnHsTyKi _ (XHsType (NHsCoreTy ty))
+  = return (XHsType (NHsCoreTy ty), emptyFVs)
     -- The emptyFVs probably isn't quite right
     -- but I don't think it matters
 
-rnHsTyKi env ty@(HsExplicitListTy ip k tys)
-  = do { checkTypeInType env ty
+rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
+  = do { checkPolyKinds env ty
        ; data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env ty))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsExplicitListTy ip k tys', fvs) }
+       ; return (HsExplicitListTy noExt ip tys', fvs) }
 
-rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
-  = do { checkTypeInType env ty
+rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
+  = do { checkPolyKinds env ty
        ; data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env ty))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsExplicitTupleTy kis tys', fvs) }
+       ; return (HsExplicitTupleTy noExt tys', fvs) }
 
-rnHsTyKi env (HsWildCardTy wc)
-  = do { checkAnonWildCard env wc
-       ; wc' <- rnAnonWildCard wc
+rnHsTyKi env (HsWildCardTy _)
+  = do { checkAnonWildCard env
+       ; wc' <- rnAnonWildCard
        ; return (HsWildCardTy wc', emptyFVs) }
          -- emptyFVs: this occurrence does not refer to a
          --           user-written binding site, so don't treat
@@ -684,9 +663,7 @@ rnHsTyKi env (HsWildCardTy wc)
 --------------
 rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
 rnTyVar env rdr_name
-  = do { name <- if   isRnKindLevel env
-                 then lookupKindOccRn rdr_name
-                 else lookupTypeOccRn rdr_name
+  = do { name <- lookupTypeOccRn rdr_name
        ; checkNamedWildCard env name
        ; return name }
 
@@ -703,10 +680,7 @@ rnHsTyOp :: Outputable a
 rnHsTyOp env overall_ty (L loc op)
   = do { ops_ok <- xoptM LangExt.TypeOperators
        ; op' <- rnTyVar env op
-       ; unless (ops_ok
-                 || op' == starKindTyConName
-                 || op' == unicodeStarKindTyConName
-                 || op' `hasKey` eqTyConKey) $
+       ; unless (ops_ok || op' `hasKey` eqTyConKey) $
            addErr (opTyErr op overall_ty)
        ; let l_op' = L loc op'
        ; return (l_op', unitFV op') }
@@ -722,21 +696,22 @@ checkWildCard env (Just doc)
 checkWildCard _ Nothing
   = return ()
 
-checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM ()
+checkAnonWildCard :: RnTyKiEnv -> RnM ()
 -- Report an error if an anonymous wildcard is illegal here
-checkAnonWildCard env wc
+checkAnonWildCard env
   = checkWildCard env mb_bad
   where
     mb_bad :: Maybe SDoc
     mb_bad | not (wildCardsAllowed env)
-           = Just (notAllowed (ppr wc))
+           = Just (notAllowed pprAnonWildCard)
            | otherwise
            = case rtke_what env of
                RnTypeBody      -> Nothing
                RnConstraint    -> Just constraint_msg
                RnTopConstraint -> Just constraint_msg
 
-    constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")
+    constraint_msg = hang
+                         (notAllowed pprAnonWildCard <+> text "in a constraint")
                         2 hint_msg
     hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
                     , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
@@ -772,26 +747,26 @@ wildCardsAllowed env
        HsTypeCtx {}        -> True
        _                   -> False
 
-rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn)
-rnAnonWildCard (AnonWildCard _)
+rnAnonWildCard :: RnM HsWildCardInfo
+rnAnonWildCard
   = do { loc <- getSrcSpanM
        ; uniq <- newUnique
        ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
        ; return (AnonWildCard (L loc name)) }
 
 ---------------
--- | Ensures either that we're in a type or that -XTypeInType is set
-checkTypeInType :: Outputable ty
+-- | Ensures either that we're in a type or that -XPolyKinds is set
+checkPolyKinds :: Outputable ty
                 => RnTyKiEnv
                 -> ty      -- ^ type
                 -> RnM ()
-checkTypeInType env ty
+checkPolyKinds env ty
   | isRnKindLevel env
-  = do { type_in_type <- xoptM LangExt.TypeInType
-       ; unless type_in_type $
+  = do { polykinds <- xoptM LangExt.PolyKinds
+       ; unless polykinds $
          addErr (text "Illegal kind:" <+> ppr ty $$
-                 text "Did you mean to enable TypeInType?") }
-checkTypeInType _ _ = return ()
+                 text "Did you mean to enable PolyKinds?") }
+checkPolyKinds _ _ = return ()
 
 notInKinds :: Outputable ty
            => RnTyKiEnv
@@ -799,7 +774,7 @@ notInKinds :: Outputable ty
            -> RnM ()
 notInKinds env ty
   | isRnKindLevel env
-  = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
+  = addErr (text "Illegal kind:" <+> ppr ty)
 notInKinds _ _ = return ()
 
 {- *****************************************************
@@ -835,87 +810,199 @@ bindLRdrNames rdrs thing_inside
 ---------------
 bindHsQTyVars :: forall a b.
                  HsDocContext
-              -> Maybe SDoc         -- if we are to check for unused tvs,
-                                    -- a phrase like "in the type ..."
-              -> Maybe a                 -- Just _  => an associated type decl
-              -> [Located RdrName]    -- Kind variables from scope, in l-to-r
-                                         -- order, but not from ...
-              -> (LHsQTyVars GhcPs)       -- ... these user-written tyvars
-              -> (LHsQTyVars GhcRn -> NameSet -> RnM (b, FreeVars))
-                  -- also returns all names used in kind signatures, for the
-                  -- TypeInType clause of Note [Complete user-supplied kind
-                  -- signatures] in HsDecls
+              -> Maybe SDoc         -- Just d => check for unused tvs
+                                    --   d is a phrase like "in the type ..."
+              -> Maybe a            -- Just _  => an associated type decl
+              -> [Located RdrName]  -- Kind variables from scope, no dups
+              -> (LHsQTyVars GhcPs)
+              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
+                  -- The Bool is True <=> all kind variables used in the
+                  -- kind signature are bound on the left.  Reason:
+                  -- the TypeInType clause of Note [Complete user-supplied
+                  -- kind signatures] in HsDecls
               -> RnM (b, FreeVars)
+
+-- See Note [bindHsQTyVars examples]
 -- (a) Bring kind variables into scope
---     both (i)  passed in (kv_bndrs)
---     and  (ii) mentioned in the kinds of tv_bndrs
+--     both (i)  passed in body_kv_occs
+--     and  (ii) mentioned in the kinds of hsq_bndrs
 -- (b) Bring type variables into scope
-bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
-  = do { bindLHsTyVarBndrs doc mb_in_doc
-                           mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
-         \ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
-         thing_inside (HsQTvs { hsq_implicit = rn_kvs
-                              , hsq_explicit = rn_bndrs
-                              , hsq_dependent = dep_var_set }) all_dep_vars }
-
-bindLHsTyVarBndrs :: forall a b.
-                     HsDocContext
-                  -> Maybe SDoc         -- if we are to check for unused tvs,
-                                        -- a phrase like "in the type ..."
-                  -> Maybe a            -- Just _  => an associated type decl
-                  -> [Located RdrName] -- Unbound kind variables from scope,
-                                          -- in l-to-r order, but not from ...
-                  -> [LHsTyVarBndr GhcPs]  -- ... these user-written tyvars
-                  -> (   [Name]  -- all kv names
-                      -> [LHsTyVarBndr GhcRn]
-                      -> NameSet -- which names, from the preceding list,
-                                 -- are used dependently within that list
-                                 -- See Note [Dependent LHsQTyVars] in TcHsType
-                      -> NameSet -- all names used in kind signatures
-                      -> RnM (b, FreeVars))
+--
+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
+  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
+       ; bndr_kv_occs <- extractHsTyVarBndrsKVs hs_tv_bndrs
+       ; rdr_env <- getLocalRdrEnv
+
+       ; let -- See Note [bindHsQTyVars examples] for what
+             -- all these various things are doing
+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+             bndrs        = map hsLTyVarLocName hs_tv_bndrs
+             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)
+                                 -- Make sure to list the binder kvs before the
+                                 -- body kvs, as mandated by
+                                 -- Note [Ordering of implicit variables]
+             implicit_kvs = filter_occs rdr_env bndrs kv_occs
+                                 -- Deleting bndrs: See Note [Kind-variable ordering]
+             -- dep_bndrs is the subset of bndrs that are dependent
+             --   i.e. appear in bndr/body_kv_occs
+             -- Can't use implicit_kvs because we've deleted bndrs from that!
+             dep_bndrs = filter (`elemRdr` kv_occs) bndrs
+             del       = deleteBys eqLocated
+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
+
+       ; traceRn "checkMixedVars3" $
+           vcat [ text "kv_occs" <+> ppr kv_occs
+                , text "bndrs"   <+> ppr hs_tv_bndrs
+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+                ]
+
+       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
+
+       ; bindLocalNamesFV implicit_kv_nms                     $
+         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
+       ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
+       ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
+                                   { hsq_implicit  = implicit_kv_nms
+                                   , hsq_dependent = mkNameSet dep_bndr_nms }
+                              , hsq_explicit  = rn_bndrs })
+                      all_bound_on_lhs } }
+
+  where
+    filter_occs :: LocalRdrEnv         -- In scope
+                -> [Located RdrName]   -- Bound here
+                -> [Located RdrName]   -- Potential implicit binders
+                -> [Located RdrName]   -- Final implicit binders
+    -- Filter out any potential implicit binders that are either
+    -- already in scope, or are explicitly bound here
+    filter_occs rdr_env bndrs occs
+      = filterOut is_in_scope occs
+      where
+        is_in_scope locc@(L _ occ) = isJust (lookupLocalRdrEnv rdr_env occ)
+                                  || locc `elemRdr` bndrs
+
+{- Note [bindHsQTyVars examples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   data T k (a::k1) (b::k) :: k2 -> k1 -> *
+
+Then:
+  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
+  bndrs       = [k,a,b]
+
+  bndr_kv_occs = [k,k1], kind variables free in kind signatures
+                         of hs_tv_bndrs
+
+  body_kv_occs = [k2,k1], kind variables free in the
+                          result kind signature
+
+  implicit_kvs = [k1,k2], kind variables free in kind signatures
+                          of hs_tv_bndrs, and not bound by bndrs
+
+* We want to quantify add implicit bindings for implicit_kvs
+
+* The "dependent" bndrs (hsq_dependent) are the subset of
+  bndrs that are free in bndr_kv_occs or body_kv_occs
+
+* If implicit_body_kvs is non-empty, then there is a kind variable
+  mentioned in the kind signature that is not bound "on the left".
+  That's one of the rules for a CUSK, so we pass that info on
+  as the second argument to thing_inside.
+
+* Order is not important in these lists.  All we are doing is
+  bring Names into scope.
+
+Finally, you may wonder why filter_occs removes in-scope variables
+from bndr/body_kv_occs.  How can anything be in scope?  Answer:
+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
+ConDecls
+   data T a = forall (b::k). MkT a b
+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
+ConDecl.  Hence the local RdrEnv may be non-empty and we must filter
+out 'a' from the free vars.  (Mind you, in this situation all the
+implicit kind variables are bound at the data type level, so there
+are none to bind in the ConDecl, so there are no implicitly bound
+variables at all.
+
+Note [Kind variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  data T (a :: k) k = ...
+we report "k is out of scope" for (a::k).  Reason: k is not brought
+into scope until the explicit k-binding that follows.  It would be
+terribly confusing to bring into scope an /implicit/ k for a's kind
+and a distinct, shadowing explicit k that follows, something like
+  data T {k1} (a :: k1) k = ...
+
+So the rule is:
+
+   the implicit binders never include any
+   of the explicit binders in the group
+
+Note that in the denerate case
+  data T (a :: a) = blah
+we get a complaint the second 'a' is not in scope.
+
+That applies to foralls too: e.g.
+   forall (a :: k) k . blah
+
+But if the foralls are split, we treat the two groups separately:
+   forall (a :: k). forall k. blah
+Here we bring into scope an implicit k, which is later shadowed
+by the explicit k.
+
+In implementation terms
+
+* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
+  the binders {a,k}, and so end with no implicit binders.  Then we
+  rename the binders left-to-right, and hence see that 'k' is out of
+  scope in the kind of 'a'.
+
+* Similarly in extract_hs_tv_bndrs
+
+Note [Variables used as both types and kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We bind the type variables tvs, and kvs is the set of free variables of the
+kinds in the scope of the binding. Here is one typical example:
+
+   forall a b. a -> (b::k) -> (c::a)
+
+Here, tvs will be {a,b}, and kvs {k,a}.
+
+We must make sure that kvs includes all of variables in the kinds of type
+variable bindings. For instance:
+
+   forall k (a :: k). Proxy a
+
+If we only look in the body of the `forall` type, we will mistakenly conclude
+that kvs is {}. But in fact, the type variable `k` is also used as a kind
+variable in (a :: k), later in the binding. (This mistake lead to #14710.)
+So tvs is {k,a} and kvs is {k}.
+
+NB: we do this only at the binding site of 'tvs'.
+-}
+
+bindLHsTyVarBndrs :: HsDocContext
+                  -> Maybe SDoc            -- Just d => check for unused tvs
+                                           --   d is a phrase like "in the type ..."
+                  -> Maybe a               -- Just _  => an associated type decl
+                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars
+                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
                   -> RnM (b, FreeVars)
-bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
   = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
-       ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
+       ; checkDupRdrNames tv_names_w_loc
+       ; go tv_bndrs thing_inside }
   where
     tv_names_w_loc = map hsLTyVarLocName tv_bndrs
 
-    go :: [Name]                 -- kind-vars found (in reverse order)
-       -> [LHsTyVarBndr GhcRn]   -- already renamed (in reverse order)
-       -> NameSet                -- kind vars already in scope (for dup checking)
-       -> NameSet                -- type vars already in scope (for dup checking)
-       -> NameSet                -- (all) variables used dependently
-       -> [LHsTyVarBndr GhcPs]   -- still to be renamed, scoped
-       -> RnM (b, FreeVars)
-    go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
-      = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
-        \ kv_nms used_dependently tv_bndr' ->
-        do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
-                            (tv_bndr' : rn_tvs)
-                            (kv_names `extendNameSetList` kv_nms)
-                            (tv_names `extendNameSet` hsLTyVarName tv_bndr')
-                            (dep_vars `unionNameSet` used_dependently)
-                            tv_bndrs
-           ; warn_unused tv_bndr' fvs
-           ; return (b, fvs) }
-
-    go rn_kvs rn_tvs _kv_names tv_names dep_vars []
-      = -- still need to deal with the kv_bndrs passed in originally
-        bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
-        do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
-                 all_rn_tvs = reverse rn_tvs
-           ; env <- getLocalRdrEnv
-           ; let all_dep_vars = dep_vars `unionNameSet` others
-                 exp_dep_vars -- variables in all_rn_tvs that are in dep_vars
-                   = mkNameSet [ name
-                               | v <- all_rn_tvs
-                               , let name = hsLTyVarName v
-                               , name `elemNameSet` all_dep_vars ]
-           ; traceRn "bindHsTyVars" (ppr env $$
-                                     ppr all_rn_kvs $$
-                                     ppr all_rn_tvs $$
-                                     ppr exp_dep_vars)
-           ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
+    go []     thing_inside = thing_inside []
+    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
+                             do { (res, fvs) <- go bs $ \ bs' ->
+                                                thing_inside (b' : bs')
+                                ; warn_unused b' fvs
+                                ; return (res, fvs) }
 
     warn_unused tv_bndr fvs = case mb_in_doc of
       Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
@@ -923,113 +1010,25 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
 
 bindLHsTyVarBndr :: HsDocContext
                  -> Maybe a   -- associated class
-                 -> NameSet   -- kind vars already in scope
-                 -> NameSet   -- type vars already in scope
                  -> LHsTyVarBndr GhcPs
-                 -> ([Name] -> NameSet -> LHsTyVarBndr GhcRn
-                        -> RnM (b, FreeVars))
-                   -- passed the newly-bound implicitly-declared kind vars,
-                   -- any other names used in a kind
-                   -- and the renamed LHsTyVarBndr
+                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
                  -> RnM (b, FreeVars)
-bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
-  = case hs_tv_bndr of
-      L loc (UserTyVar lrdr@(L lv rdr)) ->
-        do { check_dup loc rdr []
-           ; nm <- newTyVarNameRn mb_assoc lrdr
-           ; bindLocalNamesFV [nm] $
-             thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
-      L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
-        do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
-           ; check_dup lv rdr (map unLoc free_kvs)
-
-             -- check for -XKindSignatures
-           ; sig_ok <- xoptM LangExt.KindSignatures
+bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside
+  = do { nm <- newTyVarNameRn mb_assoc lrdr
+       ; bindLocalNamesFV [nm] $
+         thing_inside (L loc (UserTyVar x (L lv nm))) }
+
+bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
+                 thing_inside
+  = do { sig_ok <- xoptM LangExt.KindSignatures
            ; unless sig_ok (badKindSigErr doc kind)
+           ; (kind', fvs1) <- rnLHsKind doc kind
+           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
+           ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
+                         thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
+           ; return (b, fvs1 `plusFV` fvs2) }
 
-             -- deal with kind vars in the user-written kind
-           ; bindImplicitKvs doc mb_assoc free_kvs tv_names $
-             \ new_kv_nms other_kv_nms ->
-             do { (kind', fvs1) <- rnLHsKind doc kind
-                ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
-                ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
-                               thing_inside new_kv_nms other_kv_nms
-                                 (L loc (KindedTyVar (L lv tv_nm) kind'))
-                ; return (b, fvs1 `plusFV` fvs2) }}
-  where
-      -- make sure that the RdrName isn't in the sets of
-      -- names. We can't just check that it's not in scope at all
-      -- because we might be inside an associated class.
-    check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM ()
-    check_dup loc rdr kindFreeVars
-      = do { -- Disallow use of a type variable name in its
-             -- kind signature (#11592).
-             when (rdr `elem` kindFreeVars) $
-             addErrAt loc (vcat [ ki_ty_self_err rdr
-                                , pprHsDocContext doc ])
-
-           ; m_name <- lookupLocalOccRn_maybe rdr
-           ; whenIsJust m_name $ \name ->
-        do { when (name `elemNameSet` kv_names) $
-             addErrAt loc (vcat [ ki_ty_err_msg name
-                                , pprHsDocContext doc ])
-           ; when (name `elemNameSet` tv_names) $
-             dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
-
-    ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
-                      text "used as a kind variable before being bound" $$
-                      text "as a type variable. Perhaps reorder your variables?"
-
-    ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+>
-                       text "is used in the kind signature of its" $$
-                       text "declaration as a type variable."
-
-
-bindImplicitKvs :: HsDocContext
-                -> Maybe a
-                -> [Located RdrName]  -- ^ kind var *occurrences*, from which
-                                      -- intent to bind is inferred
-                -> NameSet            -- ^ *type* variables, for type/kind
-                                      -- misuse check for -XNoTypeInType
-                -> ([Name] -> NameSet -> RnM (b, FreeVars))
-                   -- ^ passed new kv_names, and any other names used in a kind
-                -> RnM (b, FreeVars)
-bindImplicitKvs _   _        []       _        thing_inside
-  = thing_inside [] emptyNameSet
-bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
-  = do { rdr_env <- getLocalRdrEnv
-       ; let part_kvs lrdr@(L loc kv_rdr)
-               = case lookupLocalRdrEnv rdr_env kv_rdr of
-                   Just kv_name -> Left (L loc kv_name)
-                   _            -> Right lrdr
-             (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs
-
-          -- check whether we're mixing types & kinds illegally
-       ; type_in_type <- xoptM LangExt.TypeInType
-       ; unless type_in_type $
-         mapM_ (check_tv_used_in_kind tv_names) bound_kvs
-
-       ; poly_kinds <- xoptM LangExt.PolyKinds
-       ; unless poly_kinds $
-         addErr (badKindBndrs doc new_kvs)
-
-          -- bind the vars and move on
-       ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
-       ; bindLocalNamesFV kv_nms $
-         thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
-  where
-      -- check to see if the variables free in a kind are bound as type
-      -- variables. Assume -XNoTypeInType.
-    check_tv_used_in_kind :: NameSet       -- ^ *type* variables
-                          -> Located Name  -- ^ renamed var used in kind
-                          -> RnM ()
-    check_tv_used_in_kind tv_names (L loc kv_name)
-      = when (kv_name `elemNameSet` tv_names) $
-        addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
-                             text "used in a kind." $$
-                             text "Did you mean to use TypeInType?"
-                           , pprHsDocContext doc ])
-
+bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
 
 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
 newTyVarNameRn mb_assoc (L loc rdr)
@@ -1047,44 +1046,40 @@ collectAnonWildCards lty = go lty
   where
     go (L _ ty) = case ty of
       HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
-      HsAppsTy tys                 -> gos (mapMaybe (prefix_types_only . unLoc) tys)
-      HsAppTy ty1 ty2              -> go ty1 `mappend` go ty2
-      HsFunTy ty1 ty2              -> go ty1 `mappend` go ty2
-      HsListTy ty                  -> go ty
-      HsPArrTy ty                  -> go ty
-      HsTupleTy _ tys              -> gos tys
-      HsSumTy tys                  -> gos tys
-      HsOpTy ty1 _ ty2             -> go ty1 `mappend` go ty2
-      HsParTy ty                   -> go ty
-      HsIParamTy _ ty              -> go ty
-      HsEqTy ty1 ty2               -> go ty1 `mappend` go ty2
-      HsKindSig ty kind            -> go ty `mappend` go kind
-      HsDocTy ty _                 -> go ty
-      HsBangTy _ ty                -> go ty
-      HsRecTy flds                 -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ _ tys     -> gos tys
-      HsExplicitTupleTy _ tys      -> gos tys
+      HsAppTy _ ty1 ty2              -> go ty1 `mappend` go ty2
+      HsFunTy _ ty1 ty2              -> go ty1 `mappend` go ty2
+      HsListTy _ ty                  -> go ty
+      HsTupleTy _ _ tys              -> gos tys
+      HsSumTy _ tys                  -> gos tys
+      HsOpTy _ ty1 _ ty2             -> go ty1 `mappend` go ty2
+      HsParTy _ ty                   -> go ty
+      HsIParamTy _ _ ty              -> go ty
+      HsKindSig _ ty kind            -> go ty `mappend` go kind
+      HsDocTy _ ty _                 -> go ty
+      HsBangTy _ _ ty                -> go ty
+      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ _ tys       -> gos tys
+      HsExplicitTupleTy _ tys        -> gos tys
       HsForAllTy { hst_bndrs = bndrs
                  , hst_body = ty } -> collectAnonWildCardsBndrs bndrs
                                       `mappend` go ty
       HsQualTy { hst_ctxt = L _ ctxt
                , hst_body = ty }  -> gos ctxt `mappend` go ty
-      HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
       HsSpliceTy{} -> mempty
-      HsCoreTy{} -> mempty
       HsTyLit{} -> mempty
       HsTyVar{} -> mempty
+      HsStarTy{} -> mempty
+      XHsType{} -> mempty
 
     gos = mconcat . map go
 
-    prefix_types_only (HsAppPrefix ty) = Just ty
-    prefix_types_only (HsAppInfix _)   = Nothing
-
 collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
 collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
   where
-    go (UserTyVar _)      = []
-    go (KindedTyVar _ ki) = collectAnonWildCards ki
+    go (UserTyVar _ _)      = []
+    go (KindedTyVar _ _ ki) = collectAnonWildCards ki
+    go (XTyVarBndr{})       = []
 
 {-
 *********************************************************
@@ -1112,17 +1107,20 @@ rnConDeclFields ctxt fls fields
 
 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
         -> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField names ty haddock_doc))
+rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
   = do { let new_names = map (fmap lookupField) names
        ; (new_ty, fvs) <- rnLHsTyKi env ty
        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
-       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
+       ; return (L l (ConDeclField noExt new_names new_ty new_haddock_doc)
+                , fvs) }
   where
     lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
-    lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
+    lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
       where
         lbl = occNameFS $ rdrNameOcc rdr
         fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
+    lookupField (XFieldOcc{}) = panic "rnField"
+rnField _ _ (L _ (XConDeclField _)) = panic "rnField"
 
 {-
 ************************************************************************
@@ -1156,15 +1154,15 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
            -> RnM (HsType GhcRn)
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22))
   = do  { fix2 <- lookupTyFixityRn op2
         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
-                      (\t1 t2 -> HsOpTy t1 op2 t2)
+                      (\t1 t2 -> HsOpTy noExt t1 op2 t2)
                       (unLoc op2) fix2 ty21 ty22 loc2 }
 
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))
   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
-                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
+                (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
 
 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
   = return (mk1 ty1 ty2)
@@ -1195,38 +1193,38 @@ mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged
           -> RnM (HsExpr GhcRn)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
+mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (OpApp e1 op2 fix2 e2)
+       return (OpApp fix2 e1 op2 e2)
 
   | associate_right = do
     new_e <- mkOpAppRn e12 op2 fix2 e2
-    return (OpApp e11 op1 fix1 (L loc' new_e))
+    return (OpApp fix1 e11 op1 (L loc' new_e))
   where
     loc'= combineLocs e12 e2
     (nofix_error, associate_right) = compareFixity fix1 fix2
 
 ---------------------------
 --      (- neg_arg) `op` e2
-mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
+mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
   | nofix_error
   = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
-       return (OpApp e1 op2 fix2 e2)
+       return (OpApp fix2 e1 op2 e2)
 
   | associate_right
   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
-       return (NegApp (L loc' new_e) neg_name)
+       return (NegApp noExt (L loc' new_e) neg_name)
   where
     loc' = combineLocs neg_arg e2
     (nofix_error, associate_right) = compareFixity negateFixity fix2
 
 ---------------------------
 --      e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {}))     -- NegApp can occur on the right
   | not associate_right                 -- We *want* right association
   = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
-       return (OpApp e1 op1 fix1 e2)
+       return (OpApp fix1 e1 op1 e2)
   where
     (_, associate_right) = compareFixity fix1 negateFixity
 
@@ -1236,7 +1234,7 @@ mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
   = ASSERT2( right_op_ok fix (unLoc e2),
              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
     )
-    return (OpApp e1 op fix e2)
+    return (OpApp fix e1 op e2)
 
 ----------------------------
 
@@ -1256,16 +1254,16 @@ instance Outputable OpName where
 get_op :: LHsExpr GhcRn -> OpName
 -- An unbound name could be either HsVar or HsUnboundVar
 -- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n)))   = NormalOp n
-get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
-get_op (L _ (HsRecFld fld))    = RecFldOp fld
-get_op other                   = pprPanic "get_op" (ppr other)
+get_op (L _ (HsVar _ (L _ n)))   = NormalOp n
+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (L _ (HsRecFld _ fld))    = RecFldOp fld
+get_op other                     = pprPanic "get_op" (ppr other)
 
 -- Parser left-associates everything, but
 -- derived instances may have correctly-associated things to
 -- in the right operand.  So we just check that the right operand is OK
 right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
-right_op_ok fix1 (OpApp _ _ fix2 _)
+right_op_ok fix1 (OpApp fix2 _ _ _)
   = not error_please && associate_right
   where
     (error_please, associate_right) = compareFixity fix1 fix2
@@ -1274,14 +1272,15 @@ right_op_ok _ _
 
 -- Parser initially makes negation bind more tightly than any other operator
 -- And "deriving" code should respect this (use HsPar if not)
-mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
+           -> RnM (HsExpr (GhcPass id))
 mkNegAppRn neg_arg neg_name
   = ASSERT( not_op_app (unLoc neg_arg) )
-    return (NegApp neg_arg neg_name)
+    return (NegApp noExt neg_arg neg_name)
 
 not_op_app :: HsExpr id -> Bool
-not_op_app (OpApp _ _ _ _) = False
-not_op_app _               = True
+not_op_app (OpApp {}) = False
+not_op_app _          = True
 
 ---------------------------
 mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
@@ -1290,25 +1289,24 @@ mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
           -> RnM (HsCmd GhcRn)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
-                                     [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1)
+                                     [a11,a12]))))
         op2 fix2 a2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
+       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
 
   | associate_right
   = do new_c <- mkOpFormRn a12 op2 fix2 a2
-       return (HsCmdArrForm op1 f (Just fix1)
-               [a11, L loc (HsCmdTop (L loc new_c)
-               placeHolderType placeHolderType [])])
+       return (HsCmdArrForm noExt op1 f (Just fix1)
+               [a11, L loc (HsCmdTop [] (L loc new_c))])
         -- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
 
 --      Default case
 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
-  = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
+  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
 
 
 --------------------------------------
@@ -1346,7 +1344,7 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
 checkPrecMatch op (MG { mg_alts = L _ ms })
   = mapM_ check ms
   where
-    check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
+    check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
       = setSrcSpan (combineSrcSpans l1 l2) $
         do checkPrec op p1 False
            checkPrec op p2 True
@@ -1359,6 +1357,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms })
         -- but the second eqn has no args (an error, but not discovered
         -- until the type checker).  So we don't want to crash on the
         -- second eqn.
+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
 
 checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
@@ -1386,8 +1385,8 @@ checkSectionPrec :: FixityDirection -> HsExpr GhcPs
         -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
 checkSectionPrec direction section op arg
   = case unLoc arg of
-        OpApp _ op' fix _ -> go_for_it (get_op op') fix
-        NegApp _ _        -> go_for_it NegateOp     negateFixity
+        OpApp fix _ op' _ -> go_for_it (get_op op') fix
+        NegApp _ _ _      -> go_for_it NegateOp     negateFixity
         _                 -> return ()
   where
     op_name = get_op op
@@ -1453,13 +1452,6 @@ unexpectedTypeSigErr ty
   = hang (text "Illegal type signature:" <+> quotes (ppr ty))
        2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
 
-badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
-badKindBndrs doc kvs
-  = withHsDocContext doc $
-    hang (text "Unexpected kind variable" <> plural kvs
-                 <+> pprQuotedList kvs)
-       2 (text "Perhaps you intended to use PolyKinds")
-
 badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
 badKindSigErr doc (L loc ty)
   = setSrcSpan loc $ addErr $
@@ -1496,10 +1488,6 @@ opTyErr op overall_ty
           | otherwise
           = text "Use TypeOperators to allow operators in types"
 
-emptyNonSymsErr :: HsType GhcPs -> SDoc
-emptyNonSymsErr overall_ty
-  = text "Operator applied to too few arguments:" <+> ppr overall_ty
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1533,17 +1521,103 @@ In general we want to walk over a type, and find
   * Its free type variables
   * The free kind variables of any kind signatures in the type
 
-Hence we returns a pair (kind-vars, type vars)
-See also Note [HsBSig binder lists] in HsTypes
+Hence we return a pair (kind-vars, type vars)
+(See Note [HsBSig binder lists] in HsTypes.)
+Moreover, we preserve the left-to-right order of the first occurrence of each
+variable, while preserving dependency order.
+(See Note [Ordering of implicit variables].)
+
+Most clients of this code just want to know the kind/type vars, without
+duplicates. The function rmDupsInRdrTyVars removes duplicates. That function
+also makes sure that no variable is reported as both a kind var and
+a type var, preferring kind vars. Why kind vars? Consider this:
+
+ foo :: forall (a :: k). Proxy k -> Proxy a -> ...
+
+Should that be accepted?
+
+Normally, if a type signature has an explicit forall, it must list *all*
+tyvars mentioned in the type. But there's an exception for tyvars mentioned in
+a kind, as k is above. Note that k is also used "as a type variable", as the
+argument to the first Proxy. So, do we consider k to be type-variable-like and
+require it in the forall? Or do we consider k to be kind-variable-like and not
+require it?
+
+It's not just in type signatures: kind variables are implicitly brought into
+scope in a variety of places. Should vars used at both the type level and kind
+level be treated this way?
+
+GHC indeed allows kind variables to be brought into scope implicitly even when
+the kind variable is also used as a type variable. Thus, we must prefer to keep
+a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type
+var, then this would prevent it from being implicitly quantified (see
+rnImplicitBndrs). In the `foo` example above, that would have the consequence
+of the k in Proxy k being reported as out of scope.
+
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+  const :: a -> b -> a       -- forall a b. ...
+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included
+
+  type a <-< b = b -> a
+  g :: a <-< b               -- forall a b. ...  type synonyms matter
+
+  class Functor f where
+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
+    -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does a *stable topological sort* on the variables.
+By "stable", we mean that any two variables who do not depend on each other
+preserve their existing left-to-right ordering.
+
+Implicitly bound variables are collected by any function which returns a
+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
+includes the `extract-` family of functions (extractHsTysRdrTyVars,
+extractHsTyVarBndrsKVs, etc.).
+These functions thus promise to keep left-to-right ordering.
+Look for pointers to this note to see the places where the action happens.
+
+Note that we also maintain this ordering in kind signatures. Even though
+there's no visible kind application (yet), having implicit variables be
+quantified in left-to-right order in kind signatures is nice since:
+
+* It's consistent with the treatment for type signatures.
+* It can affect how types are displayed with -fprint-explicit-kinds (see
+  #15568 for an example), which is a situation where knowing the order in
+  which implicit variables are quantified can be useful.
+* In the event that visible kind application is implemented, the order in
+  which we would expect implicit variables to be ordered in kinds will have
+  already been established.
 -}
 
+-- See Note [Kind and type-variable binders]
+-- These lists are guaranteed to preserve left-to-right ordering of
+-- the types the variables were extracted from. See also
+-- Note [Ordering of implicit variables].
 data FreeKiTyVars = FKTV { fktv_kis    :: [Located RdrName]
                          , fktv_tys    :: [Located RdrName] }
 
+-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
+type FreeKiTyVarsWithDups = FreeKiTyVars
+
+-- | A 'FreeKiTyVars' list that contains no duplicate variables.
+type FreeKiTyVarsNoDups   = FreeKiTyVars
+
 instance Outputable FreeKiTyVars where
   ppr (FKTV kis tys) = ppr (kis, tys)
 
-emptyFKTV :: FreeKiTyVars
+emptyFKTV :: FreeKiTyVarsNoDups
 emptyFKTV = FKTV [] []
 
 freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
@@ -1565,189 +1639,256 @@ filterInScope rdr_env (FKTV kis tys)
 inScope :: LocalRdrEnv -> RdrName -> Bool
 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
 
-extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars
--- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
---                        or the free (sort, kind) variables of a HsKind
--- It's used when making the for-alls explicit.
--- Does not return any wildcards
+-- | 'extractHsTyRdrTyVars' finds the
+--        free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
 -- When the same name occurs multiple times in the types, only the first
 -- occurrence is returned.
 -- See Note [Kind and type-variable binders]
+extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
 extractHsTyRdrTyVars ty
-  = do { FKTV kis tys <- extract_lty TypeLevel ty emptyFKTV
-       ; return (FKTV (nubL kis)
-                      (nubL tys)) }
+  = rmDupsInRdrTyVars <$> extractHsTyRdrTyVarsDups ty
 
+-- | 'extractHsTyRdrTyVarsDups' find the
+--        free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractHsTyRdrTyVarsDups ty
+  = extract_lty TypeLevel ty emptyFKTV
+
+-- | Extracts the free kind variables (but not the type variables) of an
+-- 'HsType'. Does not return any wildcards.
+-- When the same name occurs multiple times in the type, only the first
+-- occurrence is returned, and the left-to-right order of variables is
+-- preserved.
+-- See Note [Kind and type-variable binders] and
+-- Note [Ordering of implicit variables].
+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> RnM [Located RdrName]
+extractHsTyRdrTyVarsKindVars ty
+  = freeKiTyVarsKindVars <$> extractHsTyRdrTyVars ty
 
 -- | Extracts free type and kind variables from types in a list.
 -- When the same name occurs multiple times in the types, only the first
 -- occurrence is returned and the rest is filtered out.
 -- See Note [Kind and type-variable binders]
-extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVars
+extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVarsNoDups
 extractHsTysRdrTyVars tys
   = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
 
 -- | Extracts free type and kind variables from types in a list.
 -- When the same name occurs multiple times in the types, all occurrences
 -- are returned.
-extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVars
+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVarsWithDups
 extractHsTysRdrTyVarsDups tys
   = extract_ltys TypeLevel tys emptyFKTV
 
--- | Removes multiple occurrences of the same name from FreeKiTyVars.
-rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     However duplicates are removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extractHsTyVarBndrsKVs tv_bndrs
+  = do { kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
+       ; return (nubL kvs) }
+
+-- | Removes multiple occurrences of the same name from FreeKiTyVars. If a
+-- variable occurs as both a kind and a type variable, only keep the occurrence
+-- as a kind variable.
+-- See also Note [Kind and type-variable binders]
+rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
 rmDupsInRdrTyVars (FKTV kis tys)
-  = FKTV (nubL kis) (nubL tys)
+  = FKTV kis' tys'
+  where
+    kis' = nubL kis
+    tys' = nubL (filterOut (`elemRdr` kis') tys)
 
 extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName]
+-- Returns the free kind variables in a type family result signature, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
 extractRdrKindSigVars (L _ resultSig)
-    | KindSig k                        <- resultSig = kindRdrNameFromSig k
-    | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k
+    | KindSig _ k                          <- resultSig = kindRdrNameFromSig k
+    | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
     | otherwise = return []
     where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
 
 extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName]
 -- Get the scoped kind variables mentioned free in the constructor decls
--- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
--- Here k should scope over the whole definition
+-- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+--     Here k should scope over the whole definition
+--
+-- However, do NOT collect free kind vars from the deriving clauses:
+-- Eg: (Trac #14331)    class C p q
+--                      data D = D deriving ( C (a :: k) )
+--     Here k should /not/ scope over the whole definition.  We intend
+--     this to elaborate to:
+--         class C @k1 @k2 (p::k1) (q::k2)
+--         data D = D
+--         instance forall k (a::k). C @k @* a D where ...
+--
+-- This returns variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
-                                    , dd_cons = cons, dd_derivs = L _ derivs })
+                                    , dd_cons = cons })
   = (nubL . freeKiTyVarsKindVars) <$>
     (extract_lctxt TypeLevel ctxt =<<
      extract_mb extract_lkind ksig =<<
-     extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<
      foldrM (extract_con . unLoc) emptyFKTV cons)
   where
     extract_con (ConDeclGADT { }) acc = return acc
-    extract_con (ConDeclH98 { con_qvars = qvs
-                            , con_cxt = ctxt, con_details = details }) acc
-      = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
+    extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
+                            , con_mb_cxt = ctxt, con_args = args }) acc
+      = extract_hs_tv_bndrs ex_tvs acc =<<
         extract_mlctxt ctxt =<<
-        extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
+        extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
+    extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
 
-extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mlctxt :: Maybe (LHsContext GhcPs)
+               -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_mlctxt Nothing     acc = return acc
 extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
 
 extract_lctxt :: TypeOrKind
-              -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+              -> LHsContext GhcPs
+              -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
 
-extract_sig_tys :: [LHsSigType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_sig_tys sig_tys acc
-  = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)
-           acc sig_tys
-
 extract_ltys :: TypeOrKind
-             -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
+             -> [LHsType GhcPs]
+             -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
 
-extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
-           -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mb :: (a -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups)
+           -> Maybe a
+           -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_mb _ Nothing  acc = return acc
 extract_mb f (Just x) acc = f x acc
 
 extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lkind = extract_lty KindLevel
 
-extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_lty :: TypeOrKind -> LHsType GhcPs
+            -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
 extract_lty t_or_k (L _ ty) acc
   = case ty of
-      HsTyVar _  ltv            -> extract_tv t_or_k ltv acc
-      HsBangTy _ ty             -> extract_lty t_or_k ty acc
-      HsRecTy flds              -> foldrM (extract_lty t_or_k
-                                           . cd_fld_type . unLoc) acc
-                                         flds
-      HsAppsTy tys              -> extract_apps t_or_k tys acc
-      HsAppTy ty1 ty2           -> extract_lty t_or_k ty1 =<<
-                                   extract_lty t_or_k ty2 acc
-      HsListTy ty               -> extract_lty t_or_k ty acc
-      HsPArrTy ty               -> extract_lty t_or_k ty acc
-      HsTupleTy _ tys           -> extract_ltys t_or_k tys acc
-      HsSumTy tys               -> extract_ltys t_or_k tys acc
-      HsFunTy ty1 ty2           -> extract_lty t_or_k ty1 =<<
-                                   extract_lty t_or_k ty2 acc
-      HsIParamTy _ ty           -> extract_lty t_or_k ty acc
-      HsEqTy ty1 ty2            -> extract_lty t_or_k ty1 =<<
-                                   extract_lty t_or_k ty2 acc
-      HsOpTy ty1 tv ty2         -> extract_tv t_or_k tv =<<
-                                   extract_lty t_or_k ty1 =<<
-                                   extract_lty t_or_k ty2 acc
-      HsParTy ty                -> extract_lty t_or_k ty acc
-      HsCoreTy {}               -> return acc  -- The type is closed
-      HsSpliceTy {}             -> return acc  -- Type splices mention no tvs
-      HsDocTy ty _              -> extract_lty t_or_k ty acc
-      HsExplicitListTy _ _ tys  -> extract_ltys t_or_k tys acc
-      HsExplicitTupleTy _ tys   -> extract_ltys t_or_k tys acc
-      HsTyLit _                 -> return acc
-      HsKindSig ty ki           -> extract_lty t_or_k ty =<<
-                                   extract_lkind ki acc
+      HsTyVar _ _  ltv            -> extract_tv t_or_k ltv acc
+      HsBangTy _ _ ty             -> extract_lty t_or_k ty acc
+      HsRecTy _ flds              -> foldrM (extract_lty t_or_k
+                                             . cd_fld_type . unLoc) acc
+                                           flds
+      HsAppTy _ ty1 ty2           -> extract_lty t_or_k ty1 =<<
+                                     extract_lty t_or_k ty2 acc
+      HsListTy _ ty               -> extract_lty t_or_k ty acc
+      HsTupleTy _ _ tys           -> extract_ltys t_or_k tys acc
+      HsSumTy _ tys               -> extract_ltys t_or_k tys acc
+      HsFunTy _ ty1 ty2           -> extract_lty t_or_k ty1 =<<
+                                     extract_lty t_or_k ty2 acc
+      HsIParamTy _ _ ty           -> extract_lty t_or_k ty acc
+      HsOpTy _ ty1 tv ty2         -> extract_tv t_or_k tv =<<
+                                     extract_lty t_or_k ty1 =<<
+                                     extract_lty t_or_k ty2 acc
+      HsParTy _ ty                -> extract_lty t_or_k ty acc
+      HsSpliceTy {}               -> return acc  -- Type splices mention no tvs
+      HsDocTy _ ty _              -> extract_lty t_or_k ty acc
+      HsExplicitListTy _ _ tys    -> extract_ltys t_or_k tys acc
+      HsExplicitTupleTy _ tys     -> extract_ltys t_or_k tys acc
+      HsTyLit _ _                 -> return acc
+      HsStarTy _ _                -> return acc
+      HsKindSig _ ty ki           -> extract_lty t_or_k ty =<<
+                                     extract_lkind ki acc
       HsForAllTy { hst_bndrs = tvs, hst_body = ty }
-                                -> extract_hs_tv_bndrs tvs acc =<<
-                                   extract_lty t_or_k ty emptyFKTV
+                                  -> extract_hs_tv_bndrs tvs acc =<<
+                                     extract_lty t_or_k ty emptyFKTV
       HsQualTy { hst_ctxt = ctxt, hst_body = ty }
-                                -> extract_lctxt t_or_k ctxt   =<<
-                                   extract_lty t_or_k ty acc
+                                  -> extract_lctxt t_or_k ctxt   =<<
+                                     extract_lty t_or_k ty acc
+      XHsType {}                  -> return acc
       -- We deal with these separately in rnLHsTypeWithWildCards
-      HsWildCardTy {}           -> return acc
-
-extract_apps :: TypeOrKind
-             -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
-
-extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
-            -> RnM FreeKiTyVars
-extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
-extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
-
-extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
-                    -> FreeKiTyVars -> RnM FreeKiTyVars
+      HsWildCardTy {}             -> return acc
+
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+                 -> FreeKiTyVarsWithDups           -- Free in body
+                 -> RnM FreeKiTyVarsWithDups       -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+  = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
+
+extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+                    -> FreeKiTyVarsWithDups  -- Accumulator
+                    -> FreeKiTyVarsWithDups  -- Free in body
+                    -> RnM FreeKiTyVarsWithDups
 -- In (forall (a :: Maybe e). a -> b) we have
 --     'a' is bound by the forall
 --     'b' is a free type variable
 --     'e' is a free kind variable
-extract_hs_tv_bndrs tvs
-                    (FKTV acc_kvs acc_tvs)
-                           -- Note accumulator comes first
-                    (FKTV body_kvs body_tvs)
-  | null tvs
+extract_hs_tv_bndrs tv_bndrs
+                    (FKTV acc_kvs  acc_tvs)   -- Accumulator
+                    (FKTV body_kvs body_tvs)  -- Free in the body
+  | null tv_bndrs
   = return $
     FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)
   | otherwise
-  = do { FKTV bndr_kvs _
-           <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]
+  = do { bndr_kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
 
-       ; let locals = map hsLTyVarName tvs
-       ; return $
-         FKTV (filterOut ((`elem` locals) . unLoc) (bndr_kvs ++ body_kvs)
-                ++ acc_kvs)
-              (filterOut ((`elem` locals) . unLoc)  body_tvs ++ acc_tvs) }
-
-extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars
-           -> RnM FreeKiTyVars
-extract_tv t_or_k ltv@(L _ tv) acc
-  | isRdrTyVar tv = case acc of
-      FKTV kvs tvs
-        |  isTypeLevel t_or_k
-        -> do { when (ltv `elemRdr` kvs) $
-                mixedVarsErr ltv
-              ; return (FKTV kvs (ltv : tvs)) }
-        |  otherwise
-        -> do { when (ltv `elemRdr` tvs) $
-                mixedVarsErr ltv
-              ; return (FKTV (ltv : kvs) tvs) }
-  | otherwise     = return acc
-  where
-    elemRdr x = any (eqLocated x)
+       ; let tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
+             tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
+             -- We must include both kind variables from the binding as well
+             -- as the body of the `forall` type.
+             -- See Note [Variables used as both types and kinds].
+             all_kv_occs = bndr_kvs ++ body_kvs
 
-mixedVarsErr :: Located RdrName -> RnM ()
-mixedVarsErr (L loc tv)
-  = do { typeintype <- xoptM LangExt.TypeInType
-       ; unless typeintype $
-         addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>
-                        text "used as both a kind and a type" $$
-                        text "Did you intend to use TypeInType?" }
+       ; traceRn "checkMixedVars1" $
+           vcat [ text "bndr_kvs"     <+> ppr bndr_kvs
+                , text "body_kvs"     <+> ppr body_kvs
+                , text "all_kv_occs"  <+> ppr all_kv_occs
+                , text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ]
 
--- just used in this module; seemed convenient here
+       ; return $
+         FKTV (filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs
+                    -- NB: delete all tv_bndr_rdrs from bndr_kvs as well
+                    -- as body_kvs; see Note [Kind variable scoping]
+                ++ acc_kvs)
+              (filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs) }
+
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     Duplicates are /not/ removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extract_hs_tv_bndrs_kvs tv_bndrs
+  = do { fktvs <- foldrM extract_lkind emptyFKTV
+                  [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
+       ; return (freeKiTyVarsKindVars fktvs) }
+         -- There will /be/ no free tyvars!
+
+extract_tv :: TypeOrKind -> Located RdrName
+           -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
+extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs)
+  | not (isRdrTyVar tv) = return acc
+  | isTypeLevel t_or_k  = return (FKTV kvs (ltv : tvs))
+  | otherwise           = return (FKTV (ltv : kvs) tvs)
+
+-- Deletes duplicates in a list of Located things.
+--
+-- Importantly, this function is stable with respect to the original ordering
+-- of things in the list. This is important, as it is a property that GHC
+-- relies on to maintain the left-to-right ordering of implicitly quantified
+-- type variables.
+-- See Note [Ordering of implicit variables].
 nubL :: Eq a => [Located a] -> [Located a]
 nubL = nubBy eqLocated
+
+elemRdr :: Located RdrName -> [Located RdrName] -> Bool
+elemRdr x = any (eqLocated x)
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
index cf5dab5d37..ce5d0dc315 100644
--- a/compiler/rename/RnUnbound.hs
+++ b/compiler/rename/RnUnbound.hs
@@ -12,7 +12,10 @@ module RnUnbound ( mkUnboundName
                  , WhereLooking(..)
                  , unboundName
                  , unboundNameX
-                 , perhapsForallMsg ) where
+                 , perhapsForallMsg
+                 , notInScopeErr ) where
+
+import GhcPrelude
 
 import RdrName
 import HscTypes
@@ -58,8 +61,7 @@ unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
 unboundNameX where_look rdr_name extra
   = do  { dflags <- getDynFlags
         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
-              what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
-              err = unknownNameErr what rdr_name $$ extra
+              err = notInScopeErr rdr_name $$ extra
         ; if not show_helpful_errors
           then addErr err
           else do { local_env  <- getLocalRdrEnv
@@ -70,12 +72,13 @@ unboundNameX where_look rdr_name extra
                   ; addErr (err $$ suggestions) }
         ; return (mkUnboundNameRdr rdr_name) }
 
-unknownNameErr :: SDoc -> RdrName -> SDoc
-unknownNameErr what rdr_name
+notInScopeErr :: RdrName -> SDoc
+notInScopeErr rdr_name
   = vcat [ hang (text "Not in scope:")
               2 (what <+> quotes (ppr rdr_name))
          , extra ]
   where
+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
     extra | rdr_name == forall_tv_RDR = perhapsForallMsg
           | otherwise                 = Outputable.empty
 
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 7b2f74f1da..0451e288be 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -26,6 +26,8 @@ module RnUtils (
 where
 
 
+import GhcPrelude
+
 import HsSyn
 import RdrName
 import HscTypes
@@ -45,6 +47,7 @@ import FastString
 import Control.Monad
 import Data.List
 import Constants        ( mAX_TUPLE_SIZE )
+import qualified Data.List.NonEmpty as NE
 import qualified GHC.LanguageExtensions as LangExt
 
 {-
@@ -292,16 +295,40 @@ addNameClashErrRn rdr_name gres
                -- If there are two or more *local* defns, we'll have reported
   = return ()  -- that already, and we don't want an error cascade
   | otherwise
-  = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
-                  text "It could refer to" <+> vcat (msg1 : msgs)])
+  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
+                 , text "It could refer to"
+                 , nest 3 (vcat (msg1 : msgs)) ])
   where
     (np1:nps) = gres
-    msg1 = ptext  (sLit "either") <+> mk_ref np1
-    msgs = [text "    or" <+> mk_ref np | np <- nps]
-    mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
-      where nom = case gre_par gre of
-                    FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
-                    _                                -> quotes (ppr (gre_name gre))
+    msg1 =  text "either" <+> ppr_gre np1
+    msgs = [text "    or" <+> ppr_gre np | np <- nps]
+    ppr_gre gre = sep [ pp_gre_name gre <> comma
+                      , pprNameProvenance gre]
+
+    -- When printing the name, take care to qualify it in the same
+    -- way as the provenance reported by pprNameProvenance, namely
+    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
+    --   Ambiguous occurrence ‘null’
+    --   It could refer to either ‘T15487a.null’,
+    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
+    --                     or ...
+    -- See Trac #15487
+    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
+                         , gre_lcl = lcl, gre_imp = iss })
+      | FldParent { par_lbl = Just lbl } <- parent
+      = text "the field" <+> quotes (ppr lbl)
+      | otherwise
+      = quotes (pp_qual <> dot <> ppr (nameOccName name))
+      where
+        pp_qual | lcl
+                = ppr (nameModule name)
+                | imp : _ <- iss  -- This 'imp' is the one that
+                                  -- pprNameProvenance chooses
+                , ImpDeclSpec { is_as = mod } <- is_decl imp
+                = ppr mod
+                | otherwise
+                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
+                  -- Invariant: either 'lcl' is True or 'iss' is non-empty
 
 shadowedNameWarn :: OccName -> [SDoc] -> SDoc
 shadowedNameWarn occ shadowed_locs
@@ -316,13 +343,13 @@ unknownSubordinateErr doc op    -- Doc is "method of class" or
   = quotes (ppr op) <+> text "is not a (visible)" <+> doc
 
 
-dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
 dupNamesErr get_loc names
   = addErrAt big_loc $
-    vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
+    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
           locations]
   where
-    locs      = map get_loc names
+    locs      = map get_loc (NE.toList names)
     big_loc   = foldr1 combineSrcSpans locs
     locations = text "Bound at:" <+> vcat (map ppr (sort locs))
 
@@ -371,7 +398,6 @@ data HsDocContext
   | GHCiCtx
   | SpliceTypeCtx (LHsType GhcPs)
   | ClassInstanceCtx
-  | VectDeclCtx (Located RdrName)
   | GenericCtx SDoc   -- Maybe we want to use this more!
 
 withHsDocContext :: HsDocContext -> SDoc -> SDoc
@@ -406,5 +432,3 @@ pprHsDocContext (ConDeclCtx [name])
    = text "the definition of data constructor" <+> quotes (ppr name)
 pprHsDocContext (ConDeclCtx names)
    = text "the definition of data constructors" <+> interpp'SP names
-pprHsDocContext (VectDeclCtx tycon)
-   = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 83f5ee6a3b..96fbd07454 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -10,21 +10,24 @@ module CSE (cseProgram, cseOneExpr) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSubst
 import Var              ( Var )
-import VarEnv           ( elemInScopeSet )
-import Id               ( Id, idType, idInlineActivation, isDeadBinder
+import VarEnv           ( elemInScopeSet, mkInScopeSet )
+import Id               ( Id, idType, isDeadBinder
+                        , idInlineActivation, setInlineActivation
                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
-                        , isJoinId )
+                        , isJoinId, isJoinId_maybe )
 import CoreUtils        ( mkAltExpr, eqExpr
-                        , exprIsLiteralString
+                        , exprIsTickedString
                         , stripTicksE, stripTicksT, mkTicks )
+import CoreFVs          ( exprFreeVars )
 import Type             ( tyConAppArgs )
 import CoreSyn
 import Outputable
-import BasicTypes       ( TopLevelFlag(..), isTopLevel
-                        , isAlwaysActive, isAnyInlinePragma )
-import TrieMap
+import BasicTypes
+import CoreMap
 import Util             ( filterOut )
 import Data.List        ( mapAccumL )
 
@@ -204,8 +207,12 @@ is small).  The conclusion here is this:
   might replace <rhs> by 'bar', and then later be unable to see that it
   really was <rhs>.
 
+An except to the rule is when the INLINE pragma is not from the user, e.g. from
+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
+is then true.
+
 Note that we do not (currently) do CSE on the unfolding stored inside
-an Id, even if is a 'stable' unfolding.  That means that when an
+an Id, even if it is a 'stable' unfolding.  That means that when an
 unfolding happens, it is always faithful to what the stable unfolding
 originally was.
 
@@ -266,7 +273,28 @@ compiling ppHtml in Haddock.Backends.Xhtml).
 
 We could try and be careful by tracking which join points are still valid at
 each subexpression, but since join points aren't allocated or shared, there's
-less to gain by trying to CSE them.
+less to gain by trying to CSE them. (#13219)
+
+Note [Look inside join-point binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Another way how CSE for joint points is tricky is
+
+  let join foo x = (x, 42)
+      join bar x = (x, 42)
+  in … jump foo 1 … jump bar 2 …
+
+naively, CSE would turn this into
+
+  let join foo x = (x, 42)
+      join bar = foo
+  in … jump foo 1 … jump bar 2 …
+
+but now bar is a join point that claims arity one, but its right-hand side
+is not a lambda, breaking the join-point invariant (this was #15002).
+
+So `cse_bind` must zoom past the lambdas of a join point (using
+`collectNBinders`) and resume searching for CSE opportunities only in
+the body of the join point.
 
 Note [CSE for recursive bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -306,14 +334,16 @@ cseBind toplevel env (NonRec b e)
     (env1, b1)       = addBinder env b
     (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1
 
-cseBind _ env (Rec [(in_id, rhs)])
+cseBind toplevel env (Rec [(in_id, rhs)])
   | noCSE in_id
   = (env1, Rec [(out_id, rhs')])
 
   -- See Note [CSE for recursive bindings]
   | Just previous <- lookupCSRecEnv env out_id rhs''
   , let previous' = mkTicks ticks previous
-  = (extendCSSubst env1 in_id previous', NonRec out_id previous')
+        out_id'   = delayInlining toplevel out_id
+  = -- We have a hit in the recursive-binding cache
+    (extendCSSubst env1 in_id previous', NonRec out_id' previous')
 
   | otherwise
   = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
@@ -341,15 +371,33 @@ cseBind toplevel env (Rec pairs)
 -- which are equal to @out_rhs@.
 cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
 cse_bind toplevel env (in_id, in_rhs) out_id
-  | isTopLevel toplevel, exprIsLiteralString in_rhs
+  | isTopLevel toplevel, exprIsTickedString in_rhs
       -- See Note [Take care with literal strings]
-  = (env', (out_id, in_rhs))
+  = (env', (out_id', in_rhs))
+
+  | Just arity <- isJoinId_maybe in_id
+      -- See Note [Look inside join-point binders]
+  = let (params, in_body) = collectNBinders arity in_rhs
+        (env', params') = addBinders env params
+        out_body = tryForCSE env' in_body
+    in (env, (out_id, mkLams params' out_body))
 
   | otherwise
-  = (env', (out_id', out_rhs))
+  = (env', (out_id'', out_rhs))
   where
-    out_rhs         = tryForCSE env in_rhs
     (env', out_id') = addBinding env in_id out_id out_rhs
+    (cse_done, out_rhs) = try_for_cse env in_rhs
+    out_id'' | cse_done  = delayInlining toplevel out_id'
+             | otherwise = out_id'
+
+delayInlining :: TopLevelFlag -> Id -> Id
+-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already
+delayInlining top_lvl bndr
+  | isTopLevel top_lvl
+  , isAlwaysActive (idInlineActivation bndr)
+  = bndr `setInlineActivation` activeAfterInitial
+  | otherwise
+  = bndr
 
 addBinding :: CSEnv                      -- Includes InId->OutId cloning
            -> InVar                      -- Could be a let-bound type
@@ -384,8 +432,11 @@ addBinding env in_id out_id rhs'
                    Var {} -> True
                    _      -> False
 
+-- | Given a binder `let x = e`, this function
+-- determines whether we should add `e -> x` to the cs_map
 noCSE :: InId -> Bool
-noCSE id =  not (isAlwaysActive (idInlineActivation id))
+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
              -- See Note [CSE for INLINE and NOINLINE]
          || isAnyInlinePragma (idInlinePragma id)
              -- See Note [CSE for stable unfoldings]
@@ -425,12 +476,46 @@ The net effect is that for the y-binding we want to
   - but leave the original binding for y undisturbed
 
 This is done by cse_bind.  I got it wrong the first time (Trac #13367).
+
+Note [Delay inlining after CSE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (Trac #15445) we have
+   f,g :: Num a => a -> a
+   f x = ...f (x-1).....
+   g y = ...g (y-1) ....
+
+and we make some specialisations of 'g', either automatically, or via
+a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of
+'f' and 'g' are identical, so we get
+   f x = ...f (x-1)...
+   g = f
+   {-# RULES g @Int _ = $sg #-}
+
+Now there is terrible danger that, in an importing module, we'll inline
+'g' before we have a chance to run its specialisation!
+
+Solution: during CSE, when adding a top-level
+  g = f
+binding after a "hit" in the CSE cache, add a NOINLINE[2] activation
+to it, to ensure it's not inlined right away.
+
+Why top level only?  Because for nested bindings we are already past
+phase 2 and will never return there.
 -}
 
 tryForCSE :: CSEnv -> InExpr -> OutExpr
-tryForCSE env expr
-  | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
-  | otherwise                        = expr'
+tryForCSE env expr = snd (try_for_cse env expr)
+
+try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)
+-- (False, e') => We did not CSE the entire expression,
+--                but we might have CSE'd some sub-expressions,
+--                yielding e'
+--
+-- (True, te') => We CSE'd the entire expression,
+--                yielding the trivial expression te'
+try_for_cse env expr
+  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)
+  | otherwise                        = (False, expr')
     -- The varToCoreExpr is needed if we have
     --   case e of xco { ...case e of yco { ... } ... }
     -- Then CSE will substitute yco -> xco;
@@ -444,8 +529,13 @@ tryForCSE env expr
     -- top of the replaced sub-expression. This is probably not too
     -- useful in practice, but upholds our semantics.
 
+-- | Runs CSE on a single expression.
+--
+-- This entry point is not used in the compiler itself, but is provided
+-- as a convenient entry point for users of the GHC API.
 cseOneExpr :: InExpr -> OutExpr
-cseOneExpr = cseExpr emptyCSEnv
+cseOneExpr e = cseExpr env e
+  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
 
 cseExpr :: CSEnv -> InExpr -> OutExpr
 cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)
@@ -454,7 +544,7 @@ cseExpr _   (Lit lit)             = Lit lit
 cseExpr env (Var v)               = lookupSubst env v
 cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
 cseExpr env (Tick t e)            = Tick t (cseExpr env e)
-cseExpr env (Cast e co)           = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
+cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
 cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                     in Lam b' (cseExpr env' e)
 cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind
@@ -530,9 +620,9 @@ to transform
    W y z   -> e2
 
 In the simplifier we use cheapEqExpr, because it is called a lot.
-But here in CSE we use the full eqExpr.  After all, two alterantives usually
+But here in CSE we use the full eqExpr.  After all, two alternatives usually
 differ near the root, so it probably isn't expensive to compare the full
-alternative.  It seems like the the same kind of thing that CSE is supposed
+alternative.  It seems like the same kind of thing that CSE is supposed
 to be doing, which is why I put it here.
 
 I acutally saw some examples in the wild, where some inlining made e1 too
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 0cf0c2f44f..ba1aa243ac 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -7,6 +7,8 @@ module CallArity
     , callArityRHS -- for testing
     ) where
 
+import GhcPrelude
+
 import VarSet
 import VarEnv
 import DynFlags ( DynFlags )
@@ -340,7 +342,7 @@ For a mutually recursive let, we begin by
  3. We combine the analysis result from the body and the memoized results for
     the arguments (if already present).
  4. For each variable, we find out the incoming arity and whether it is called
-    once, based on the the current analysis result. If this differs from the
+    once, based on the current analysis result. If this differs from the
     memoized results, we re-analyse the rhs and update the memoized table.
  5. If nothing had to be reanalyzed, we are done.
     Otherwise, repeat from step 3.
@@ -350,7 +352,7 @@ Note [Thunks in recursive groups]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 We never eta-expand a thunk in a recursive group, on the grounds that if it is
-part of a recursive group, then it will be called multipe times.
+part of a recursive group, then it will be called multiple times.
 
 This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not
 t1) in the following code:
@@ -404,7 +406,7 @@ published papers on Call Arity describe it.
 
 In practice, there are thunks that do a just little work, such as
 pattern-matching on a variable, and the benefits of eta-expansion likely
-oughtweigh the cost of doing that repeatedly. Therefore, this implementation of
+outweigh the cost of doing that repeatedly. Therefore, this implementation of
 Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
 
 Note [Call Arity and Join Points]
@@ -733,7 +735,7 @@ domRes (_, ae) = varEnvDom ae
 lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
 lookupCallArityRes (g, ae) v
     = case lookupVarEnv ae v of
-        Just a -> (a, not (v `elemUnVarSet` (neighbors g v)))
+        Just a -> (a, not (g `hasLoopAt` v))
         Nothing -> (0, False)
 
 calledWith :: CallArityRes -> Var -> UnVarSet
@@ -758,4 +760,4 @@ lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
 lubArityEnv = plusVarEnv_C min
 
 lubRess :: [CallArityRes] -> CallArityRes
-lubRess = foldl lubRes emptyArityRes
+lubRess = foldl' lubRes emptyArityRes
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index c689eea346..0c5d8d9fd2 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -9,12 +9,12 @@
 module CoreMonad (
     -- * Configuration of the core-to-core passes
     CoreToDo(..), runWhen, runMaybe,
-    SimplifierMode(..),
+    SimplMode(..),
     FloatOutSwitches(..),
     pprPassDetails,
 
     -- * Plugins
-    PluginPass, bindsOnlyPass,
+    CorePluginPass, bindsOnlyPass,
 
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
@@ -47,14 +47,11 @@ module CoreMonad (
     putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
-
-    -- * Getting 'Name's
-    thNameToGhcName
+    dumpIfSet_dyn
   ) where
 
-import Name( Name )
-import TcRnMonad        ( initTcForLookup )
+import GhcPrelude hiding ( read )
+
 import CoreSyn
 import HscTypes
 import Module
@@ -64,13 +61,11 @@ import Annotations
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
-import TcEnv            ( lookupGlobal )
 import Var
 import Outputable
 import FastString
 import qualified ErrUtils as Err
 import ErrUtils( Severity(..) )
-import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
 import MonadUtils
@@ -87,11 +82,6 @@ import Data.Word
 import Control.Monad
 import Control.Applicative ( Alternative(..) )
 
-import Prelude hiding   ( read )
-
-import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
-import qualified Language.Haskell.TH as TH
-
 {-
 ************************************************************************
 *                                                                      *
@@ -107,14 +97,15 @@ data CoreToDo           -- These are diff core-to-core passes,
 
   = CoreDoSimplify      -- The core-to-core simplifier.
         Int                    -- Max iterations
-        SimplifierMode
-  | CoreDoPluginPass String PluginPass
+        SimplMode
+  | CoreDoPluginPass String CorePluginPass
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
   | CoreDoPrintCore
   | CoreDoStaticArgs
   | CoreDoCallArity
+  | CoreDoExitify
   | CoreDoStrictness
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
@@ -122,7 +113,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
-  | CoreDoVectorisation
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
@@ -142,12 +132,12 @@ instance Outputable CoreToDo where
   ppr CoreLiberateCase         = text "Liberate case"
   ppr CoreDoStaticArgs         = text "Static argument"
   ppr CoreDoCallArity          = text "Called arity analysis"
+  ppr CoreDoExitify            = text "Exitification transformation"
   ppr CoreDoStrictness         = text "Demand analysis"
   ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"
   ppr CoreDoSpecialising       = text "Specialise"
   ppr CoreDoSpecConstr         = text "SpecConstr"
   ppr CoreCSE                  = text "Common sub-expression"
-  ppr CoreDoVectorisation      = text "Vectorisation"
   ppr CoreDesugar              = text "Desugar (before optimization)"
   ppr CoreDesugarOpt           = text "Desugar (after optimization)"
   ppr CoreTidy                 = text "Tidy Core"
@@ -163,17 +153,19 @@ pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
                                             , ppr md ]
 pprPassDetails _ = Outputable.empty
 
-data SimplifierMode             -- See comments in SimplMonad
+data SimplMode             -- See comments in SimplMonad
   = SimplMode
         { sm_names      :: [String] -- Name(s) of the phase
         , sm_phase      :: CompilerPhase
+        , sm_dflags     :: DynFlags -- Just for convenient non-monadic
+                                    -- access; we don't override these
         , sm_rules      :: Bool     -- Whether RULES are enabled
         , sm_inline     :: Bool     -- Whether inlining is enabled
         , sm_case_case  :: Bool     -- Whether case-of-case is enabled
         , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
         }
 
-instance Outputable SimplifierMode where
+instance Outputable SimplMode where
     ppr (SimplMode { sm_phase = p, sm_names = ss
                    , sm_rules = r, sm_inline = i
                    , sm_eta_expand = eta, sm_case_case = cc })
@@ -235,7 +227,7 @@ runMaybe Nothing  _ = CoreDoNothing
 -}
 
 -- | A description of the plugin pass itself
-type PluginPass = ModGuts -> CoreM ModGuts
+type CorePluginPass = ModGuts -> CoreM ModGuts
 
 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 bindsOnlyPass pass guts
@@ -251,7 +243,7 @@ bindsOnlyPass pass guts
 -}
 
 getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
-getVerboseSimplStats = sdocWithPprDebug          -- For now, anyway
+getVerboseSimplStats = getPprDebug          -- For now, anyway
 
 zeroSimplCount     :: DynFlags -> SimplCount
 isZeroSimplCount   :: SimplCount -> Bool
@@ -341,6 +333,79 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
           else Outputable.empty
     ]
 
+{- Note [Which transformations are innocuous]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At one point (Jun 18) I wondered if some transformations (ticks)
+might be  "innocuous", in the sense that they do not unlock a later
+transformation that does not occur in the same pass.  If so, we could
+refrain from bumping the overall tick-count for such innocuous
+transformations, and perhaps terminate the simplifier one pass
+earlier.
+
+BUt alas I found that virtually nothing was innocuous!  This Note
+just records what I learned, in case anyone wants to try again.
+
+These transformations are not innocuous:
+
+*** NB: I think these ones could be made innocuous
+          EtaExpansion
+          LetFloatFromLet
+
+LetFloatFromLet
+    x = K (let z = e2 in Just z)
+  prepareRhs transforms to
+    x2 = let z=e2 in Just z
+    x  = K xs
+  And now more let-floating can happen in the
+  next pass, on x2
+
+PreInlineUnconditionally
+  Example in spectral/cichelli/Auxil
+     hinsert = ...let lo = e in
+                  let j = ...lo... in
+                  case x of
+                    False -> ()
+                    True -> case lo of I# lo' ->
+                              ...j...
+  When we PreInlineUnconditionally j, lo's occ-info changes to once,
+  so it can be PreInlineUnconditionally in the next pass, and a
+  cascade of further things can happen.
+
+PostInlineUnconditionally
+  let x = e in
+  let y = ...x.. in
+  case .. of { A -> ...x...y...
+               B -> ...x...y... }
+  Current postinlineUnconditinaly will inline y, and then x; sigh.
+
+  But PostInlineUnconditionally might also unlock subsequent
+  transformations for the same reason as PreInlineUnconditionally,
+  so it's probably not innocuous anyway.
+
+KnownBranch, BetaReduction:
+  May drop chunks of code, and thereby enable PreInlineUnconditionally
+  for some let-binding which now occurs once
+
+EtaExpansion:
+  Example in imaginary/digits-of-e1
+    fail = \void. e          where e :: IO ()
+  --> etaExpandRhs
+    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())
+  --> Next iteration of simplify
+    fail1 = \void. \s. (e |> g) s
+    fail = fail1 |> Void#->sym g
+  And now inline 'fail'
+
+CaseMerge:
+  case x of y {
+    DEFAULT -> case y of z { pi -> ei }
+    alts2 }
+  ---> CaseMerge
+    case x of { pi -> let z = y in ei
+              ; alts2 }
+  The "let z=y" case-binder-swap gets dealt with in the next pass
+-}
+
 pprTickCounts :: Map Tick Int -> SDoc
 pprTickCounts counts
   = vcat (map pprTickGroup groups)
@@ -358,7 +423,7 @@ pprTickGroup group@((tick1,_):_)
                | (tick,n) <- sortBy (flip (comparing snd)) group])
 pprTickGroup [] = panic "pprTickGroup"
 
-data Tick
+data Tick  -- See Note [Which transformations are innocuous]
   = PreInlineUnconditionally    Id
   | PostInlineUnconditionally   Id
 
@@ -379,7 +444,6 @@ data Tick
   | CaseIdentity                Id      -- Case binder
   | FillInCaseDefault           Id      -- Case binder
 
-  | BottomFound
   | SimplifierDone              -- Ticked at each iteration of the simplifier
 
 instance Outputable Tick where
@@ -408,7 +472,6 @@ tickToTag (CaseMerge _)                 = 10
 tickToTag (CaseElim _)                  = 11
 tickToTag (CaseIdentity _)              = 12
 tickToTag (FillInCaseDefault _)         = 13
-tickToTag BottomFound                   = 14
 tickToTag SimplifierDone                = 16
 tickToTag (AltMerge _)                  = 17
 
@@ -428,7 +491,6 @@ tickString (AltMerge _)                 = "AltMerge"
 tickString (CaseElim _)                 = "CaseElim"
 tickString (CaseIdentity _)             = "CaseIdentity"
 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
-tickString BottomFound                  = "BottomFound"
 tickString SimplifierDone               = "SimplifierDone"
 
 pprTickCts :: Tick -> SDoc
@@ -780,34 +842,3 @@ dumpIfSet_dyn flag str doc
        ; unqual <- getPrintUnqualified
        ; when (dopt flag dflags) $ liftIO $
          Err.dumpSDoc dflags unqual flag str doc }
-
-{-
-************************************************************************
-*                                                                      *
-               Finding TyThings
-*                                                                      *
-************************************************************************
--}
-
-instance MonadThings CoreM where
-    lookupThing name = do { hsc_env <- getHscEnv
-                          ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-*                                                                      *
-               Template Haskell interoperability
-*                                                                      *
-************************************************************************
--}
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name = do
-    hsc_env <- getHscEnv
-    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
diff --git a/compiler/simplCore/CoreMonad.hs-boot b/compiler/simplCore/CoreMonad.hs-boot
new file mode 100644
index 0000000000..206675e5e2
--- /dev/null
+++ b/compiler/simplCore/CoreMonad.hs-boot
@@ -0,0 +1,37 @@
+-- Created this hs-boot file to remove circular dependencies from the use of
+-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core
+-- transformations.
+-- However CoreMonad does much more than defining these, and because Plugins are
+-- activated in various modules, the imports become circular. To solve this I
+-- extracted CoreToDo and CoreM into this file.
+-- I needed to write the whole definition of these types, otherwise it created
+-- a data-newtype conflict.
+
+module CoreMonad ( CoreToDo, CoreM ) where
+
+import GhcPrelude
+
+import IOEnv ( IOEnv )
+import UniqSupply ( UniqSupply )
+
+newtype CoreState = CoreState {
+        cs_uniq_supply :: UniqSupply
+}
+
+type CoreIOEnv = IOEnv CoreReader
+
+data CoreReader
+
+newtype CoreWriter = CoreWriter {
+        cw_simpl_count :: SimplCount
+}
+
+data SimplCount
+
+newtype CoreM a
+          = CoreM { unCoreM :: CoreState
+                                 -> CoreIOEnv (a, CoreState, CoreWriter) }
+
+instance Monad CoreM
+
+data CoreToDo
diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
new file mode 100644
index 0000000000..3e7d503d31
--- /dev/null
+++ b/compiler/simplCore/Exitify.hs
@@ -0,0 +1,499 @@
+module Exitify ( exitifyProgram ) where
+
+{-
+Note [Exitification]
+~~~~~~~~~~~~~~~~~~~~
+
+This module implements Exitification. The goal is to pull as much code out of
+recursive functions as possible, as the simplifier is better at inlining into
+call-sites that are not in recursive functions.
+
+Example:
+
+  let t = foo bar
+  joinrec go 0     x y = t (x*x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+We’d like to inline `t`, but that does not happen: Because t is a thunk and is
+used in a recursive function, doing so might lose sharing in general. In
+this case, however, `t` is on the _exit path_ of `go`, so called at most once.
+How do we make this clearly visible to the simplifier?
+
+A code path (i.e., an expression in a tail-recursive position) in a recursive
+function is an exit path if it does not contain a recursive call. We can bind
+this expression outside the recursive function, as a join-point.
+
+Example result:
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Now `t` is no longer in a recursive function, and good things happen!
+-}
+
+import GhcPrelude
+import Var
+import Id
+import IdInfo
+import CoreSyn
+import CoreUtils
+import State
+import Unique
+import VarSet
+import VarEnv
+import CoreFVs
+import FastString
+import Type
+import Util( mapSnd )
+
+import Data.Bifunctor
+import Control.Monad
+
+-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.
+-- The really interesting function is exitifyRec
+exitifyProgram :: CoreProgram -> CoreProgram
+exitifyProgram binds = map goTopLvl binds
+  where
+    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)
+    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)
+      -- Top-level bindings are never join points
+
+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
+
+    go :: InScopeSet -> CoreExpr -> CoreExpr
+    go _    e@(Var{})       = e
+    go _    e@(Lit {})      = e
+    go _    e@(Type {})     = e
+    go _    e@(Coercion {}) = e
+    go in_scope (Cast e' c) = Cast (go in_scope e') c
+    go in_scope (Tick t e') = Tick t (go in_scope e')
+    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)
+
+    go in_scope (Lam v e')
+      = Lam v (go in_scope' e')
+      where in_scope' = in_scope `extendInScopeSet` v
+
+    go in_scope (Case scrut bndr ty alts)
+      = Case (go in_scope scrut) bndr ty (map go_alt alts)
+      where
+        in_scope1 = in_scope `extendInScopeSet` bndr
+        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)
+           where in_scope' = in_scope1 `extendInScopeSetList` pats
+
+    go in_scope (Let (NonRec bndr rhs) body)
+      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)
+      where
+        in_scope' = in_scope `extendInScopeSet` bndr
+
+    go in_scope (Let (Rec pairs) body)
+      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
+      | otherwise   = Let (Rec pairs') body'
+      where
+        is_join_rec = any (isJoinId . fst) pairs
+        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)
+        pairs'      = mapSnd (go in_scope') pairs
+        body'       = go in_scope' body
+
+
+-- | State Monad used inside `exitify`
+type ExitifyM =  State [(JoinId, CoreExpr)]
+
+-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
+--   join-points outside the joinrec.
+exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec in_scope pairs
+  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
+  where
+    -- We need the set of free variables of many subexpressions here, so
+    -- annotate the AST with them
+    -- see Note [Calculating free variables]
+    ann_pairs = map (second freeVars) pairs
+
+    -- Which are the recursive calls?
+    recursive_calls = mkVarSet $ map fst pairs
+
+    (pairs',exits) = (`runState` []) $ do
+        forM ann_pairs $ \(x,rhs) -> do
+            -- go past the lambdas of the join point
+            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
+            body' <- go args body
+            let rhs' = mkLams args body'
+            return (x, rhs')
+
+    ---------------------
+    -- 'go' is the main working function.
+    -- It goes through the RHS (tail-call positions only),
+    -- checks if there are no more recursive calls, if so, abstracts over
+    -- variables bound on the way and lifts it out as a join point.
+    --
+    -- ExitifyM is a state monad to keep track of floated binds
+    go :: [Var]           -- ^ Variables that are in-scope here, but
+                          -- not in scope at the joinrec; that is,
+                          -- we must potentially abstract over them.
+                          -- Invariant: they are kept in dependency order
+       -> CoreExprWithFVs -- ^ Current expression in tail position
+       -> ExitifyM CoreExpr
+
+    -- We first look at the expression (no matter what it shape is)
+    -- and determine if we can turn it into a exit join point
+    go captured ann_e
+        | -- An exit expression has no recursive calls
+          let fvs = dVarSetToVarSet (freeVarsOf ann_e)
+        , disjointVarSet fvs recursive_calls
+        = go_exit captured (deAnnotate ann_e) fvs
+
+    -- We could not turn it into a exit joint point. So now recurse
+    -- into all expression where eligible exit join points might sit,
+    -- i.e. into all tail-call positions:
+
+    -- Case right hand sides are in tail-call position
+    go captured (_, AnnCase scrut bndr ty alts) = do
+        alts' <- forM alts $ \(dc, pats, rhs) -> do
+            rhs' <- go (captured ++ [bndr] ++ pats) rhs
+            return (dc, pats, rhs')
+        return $ Case (deAnnotate scrut) bndr ty alts'
+
+    go captured (_, AnnLet ann_bind body)
+        -- join point, RHS and body are in tail-call position
+        | AnnNonRec j rhs <- ann_bind
+        , Just join_arity <- isJoinId_maybe j
+        = do let (params, join_body) = collectNAnnBndrs join_arity rhs
+             join_body' <- go (captured ++ params) join_body
+             let rhs' = mkLams params join_body'
+             body' <- go (captured ++ [j]) body
+             return $ Let (NonRec j rhs') body'
+
+        -- rec join point, RHSs and body are in tail-call position
+        | AnnRec pairs <- ann_bind
+        , isJoinId (fst (head pairs))
+        = do let js = map fst pairs
+             pairs' <- forM pairs $ \(j,rhs) -> do
+                 let join_arity = idJoinArity j
+                     (params, join_body) = collectNAnnBndrs join_arity rhs
+                 join_body' <- go (captured ++ js ++ params) join_body
+                 let rhs' = mkLams params join_body'
+                 return (j, rhs')
+             body' <- go (captured ++ js) body
+             return $ Let (Rec pairs') body'
+
+        -- normal Let, only the body is in tail-call position
+        | otherwise
+        = do body' <- go (captured ++ bindersOf bind ) body
+             return $ Let bind body'
+      where bind = deAnnBind ann_bind
+
+    -- Cannot be turned into an exit join point, but also has no
+    -- tail-call subexpression. Nothing to do here.
+    go _ ann_e = return (deAnnotate ann_e)
+
+    ---------------------
+    go_exit :: [Var]      -- Variables captured locally
+            -> CoreExpr   -- An exit expression
+            -> VarSet     -- Free vars of the expression
+            -> ExitifyM CoreExpr
+    -- go_exit deals with a tail expression that is floatable
+    -- out as an exit point; that is, it mentions no recursive calls
+    go_exit captured e fvs
+      -- Do not touch an expression that is already a join jump where all arguments
+      -- are captured variables. See Note [Idempotency]
+      -- But _do_ float join jumps with interesting arguments.
+      -- See Note [Jumps can be interesting]
+      | (Var f, args) <- collectArgs e
+      , isJoinId f
+      , all isCapturedVarArg args
+      = return e
+
+      -- Do not touch a boring expression (see Note [Interesting expression])
+      | not is_interesting
+      = return e
+
+      -- Cannot float out if local join points are used, as
+      -- we cannot abstract over them
+      | captures_join_points
+      = return e
+
+      -- We have something to float out!
+      | otherwise
+      = do { -- Assemble the RHS of the exit join point
+             let rhs   = mkLams abs_vars e
+                 avoid = in_scope `extendInScopeSetList` captured
+             -- Remember this binding under a suitable name
+           ; v <- addExit avoid (length abs_vars) rhs
+             -- And jump to it from here
+           ; return $ mkVarApps (Var v) abs_vars }
+
+      where
+        -- Used to detect exit expressoins that are already proper exit jumps
+        isCapturedVarArg (Var v) = v `elem` captured
+        isCapturedVarArg _ = False
+
+        -- An interesting exit expression has free, non-imported
+        -- variables from outside the recursive group
+        -- See Note [Interesting expression]
+        is_interesting = anyVarSet isLocalId $
+                         fvs `minusVarSet` mkVarSet captured
+
+        -- The arguments of this exit join point
+        -- See Note [Picking arguments to abstract over]
+        abs_vars = snd $ foldr pick (fvs, []) captured
+          where
+            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)
+                               | otherwise           = (fvs',               acc)
+
+        -- We are going to abstract over these variables, so we must
+        -- zap any IdInfo they have; see Trac #15005
+        -- cf. SetLevels.abstractVars
+        zap v | isId v = setIdInfo v vanillaIdInfo
+              | otherwise = v
+
+        -- We cannot abstract over join points
+        captures_join_points = any isJoinId abs_vars
+
+
+-- Picks a new unique, which is disjoint from
+--  * the free variables of the whole joinrec
+--  * any bound variables (captured)
+--  * any exit join points created so far.
+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
+mkExitJoinId in_scope ty join_arity = do
+    fs <- get
+    let avoid = in_scope `extendInScopeSetList` (map fst fs)
+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
+    return (uniqAway avoid exit_id_tmpl)
+  where
+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty
+                    `asJoinId` join_arity
+
+addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope join_arity rhs = do
+    -- Pick a suitable name
+    let ty = exprType rhs
+    v <- mkExitJoinId in_scope ty join_arity
+    fs <- get
+    put ((v,rhs):fs)
+    return v
+
+{-
+Note [Interesting expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want this to happen:
+
+  joinrec go 0     x y = x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+because the floated exit path (`x`) is simply a parameter of `go`; there are
+not useful interactions exposed this way.
+
+Neither do we want this to happen
+
+  joinrec go 0     x y = x+x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x+x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+where the floated expression `x+x` is a bit more complicated, but still not
+intersting.
+
+Expressions are interesting when they move an occurrence of a variable outside
+the recursive `go` that can benefit from being obviously called once, for example:
+ * a local thunk that can then be inlined (see example in note [Exitification])
+ * the parameter of a function, where the demand analyzer then can then
+   see that it is called at most once, and hence improve the function’s
+   strictness signature
+
+So we only hoist an exit expression out if it mentiones at least one free,
+non-imported variable.
+
+Note [Jumps can be interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A jump to a join point can be interesting, if its arguments contain free
+non-exported variables (z in the following example):
+
+  joinrec go 0     x y = jump j (x+z)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x y = jump j (x+z)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+
+
+The join point itself can be interesting, even if none if its
+arguments have free variables free in the joinrec.  For example
+
+  join j p = case p of (x,y) -> x+y
+  joinrec go 0     x y = jump j (x,y)
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+Here, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]). But
+if we exitify the 'jump j (x,y)' we get
+
+  join j p = case p of (x,y) -> x+y
+  join exit x y = jump j (x,y)
+  joinrec go 0     x y = jump exit x y
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+and now 'j' can inline, and we get rid of the pair. Here's another
+example (assume `g` to be an imported function that, on its own,
+does not make this interesting):
+
+  join j y = map f y
+  joinrec go 0     x y = jump j (map g x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Again, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]).
+
+But after exitification we have
+
+  join j y = map f y
+  join exit x = jump j (map g x)
+  joinrec go 0     x y = jump j (map g x)
+              go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+and now we can inline `j` and this will allow `map/map` to fire.
+
+
+Note [Idempotency]
+~~~~~~~~~~~~~~~~~~
+
+We do not want this to happen, where we replace the floated expression with
+essentially the same expression:
+
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = t (x*x)
+  join exit' x = jump exit x
+  joinrec go 0     x y = jump exit' x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+So when the RHS is a join jump, and all of its arguments are captured variables,
+then we leave it in place.
+
+Note that `jump exit x` in this example looks interesting, as `exit` is a free
+variable. Therefore, idempotency does not simply follow from floating only
+interesting expressions.
+
+Note [Calculating free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have two options where to annotate the tree with free variables:
+
+ A) The whole tree.
+ B) Each individual joinrec as we come across it.
+
+Downside of A: We pay the price on the whole module, even outside any joinrecs.
+Downside of B: We pay the price per joinrec, possibly multiple times when
+joinrecs are nested.
+
+Further downside of A: If the exitify function returns annotated expressions,
+it would have to ensure that the annotations are correct.
+
+We therefore choose B, and calculate the free variables in `exitify`.
+
+
+Note [Do not inline exit join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+we do not want the simplifier to simply inline `exit` back in (which it happily
+would).
+
+To prevent this, we need to recognize exit join points, and then disable
+inlining.
+
+Exit join points, recognizeable using `isExitJoinId` are join points with an
+occurence in a recursive group, and can be recognized (after the occurence
+analyzer ran!) using `isExitJoinId`.
+This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
+because the lambdas of a non-recursive join point are not considered for
+`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked
+occ_in_lam, because `j2` is called only once.
+
+  join j1 x = x+1
+  join j2 y = join j1 (y+2)
+
+To prevent inlining, we check for isExitJoinId
+* In `preInlineUnconditionally` directly.
+* In `simplLetUnfolding` we simply give exit join points no unfolding, which
+  prevents inlining in `postInlineUnconditionally` and call sites.
+
+Note [Placement of the exitification pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Joachim) experimented with multiple positions for the Exitification pass in
+the Core2Core pipeline:
+
+ A) Before the `simpl_phases`
+ B) Between the `simpl_phases` and the "main" simplifier pass
+ C) After demand_analyser
+ D) Before the final simplification phase
+
+Here is the table (this is without inlining join exit points in the final
+simplifier run):
+
+        Program |                       Allocs                      |                      Instrs
+                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log
+----------------|---------------------------------------------------|-------------------------------------------------
+ fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%
+          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%
+            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%
+           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%
+   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%
+            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%
+         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%
+  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%
+----------------|---------------------------------------------------|-------------------------------------------------
+            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%
+            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%
+ Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%
+
+Position A is disqualified, as it does not get rid of the allocations in
+fannkuch-redux.
+Position A and B are disqualified because it increases instructions in k-nucleotide.
+Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.
+
+Assuming we have a budget of _one_ run of Exitification, then C wins (but we
+could get more from running it multiple times, as seen in fish).
+
+Note [Picking arguments to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When we create an exit join point, so we need to abstract over those of its
+free variables that are be out-of-scope at the destination of the exit join
+point. So we go through the list `captured` and pick those that are actually
+free variables of the join point.
+
+We do not just `filter (`elemVarSet` fvs) captured`, as there might be
+shadowing, and `captured` may contain multiple variables with the same Unique. I
+these cases we want to abstract only over the last occurence, hence the `foldr`
+(with emphasis on the `r`). This is #15110.
+
+-}
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
index 3e44e81cea..2593b1d7a1 100644
--- a/compiler/simplCore/FloatIn.hs
+++ b/compiler/simplCore/FloatIn.hs
@@ -19,6 +19,8 @@ module FloatIn ( floatInwards ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import MkCore
 import HscTypes         ( ModGuts(..) )
@@ -179,7 +181,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
          -- lists without evaluating extra_fvs, and hence without
          -- peering into each argument
 
-    (_, extra_fvs) = foldl add_arg (fun_ty, extra_fvs0) ann_args
+    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
     extra_fvs0 = case ann_fun of
                    (_, AnnVar _) -> fun_fvs
                    _             -> emptyDVarSet
@@ -413,6 +415,16 @@ But there are wrinkles
   cases like Trac #5658.   This is implemented in sepBindsByJoinPoint;
   if is_case is False we dump all floating cases right here.
 
+* Trac #14511 is another example of why we want to restrict float-in
+  of case-expressions.  Consider
+     case indexArray# a n of (# r #) -> writeArray# ma i (f r)
+  Now, floating that indexing operation into the (f r) thunk will
+  not create any new thunks, but it will keep the array 'a' alive
+  for much longer than the programmer expected.
+
+  So again, not floating a case into a let or argument seems like
+  the Right Thing
+
 For @Case@, the possible drop points for the 'to_drop'
 bindings are:
   (a) inside the scrutinee
@@ -459,7 +471,7 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
     alts_fvs     = map alt_fvs alts
     all_alts_fvs = unionDVarSets alts_fvs
     alt_fvs (_con, args, rhs)
-      = foldl delDVarSet (freeVarsOf rhs) (case_bndr:args)
+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
            -- Delete case_bndr and args from free vars of rhs
            -- to get free vars of alt
 
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
index 72fc0d1ff7..6cb21f9470 100644
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -11,6 +11,8 @@
 
 module FloatOut ( floatOutwards ) where
 
+import GhcPrelude
+
 import CoreSyn
 import CoreUtils
 import MkCore
@@ -21,7 +23,6 @@ import DynFlags
 import ErrUtils         ( dumpIfSet_dyn )
 import Id               ( Id, idArity, idType, isBottomingId,
                           isJoinId, isJoinId_maybe )
-import BasicTypes       ( TopLevelFlag(..), isTopLevel )
 import SetLevels
 import UniqSupply       ( UniqSupply )
 import Bag
@@ -735,26 +736,19 @@ atJoinCeiling (fs, floats, expr')
 
 wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
 wrapTick t (FB tops ceils defns)
-  = FB (mapBag (wrap_bind TopLevel) tops)
-       (wrap_defns NotTopLevel ceils)
-       (M.map (M.map (wrap_defns NotTopLevel)) defns)
+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)
+       (M.map (M.map wrap_defns) defns)
   where
-    wrap_defns toplvl = mapBag (wrap_one toplvl)
-
-    wrap_bind toplvl (NonRec binder rhs) = NonRec binder (maybe_tick toplvl rhs)
-    wrap_bind toplvl (Rec pairs)         = Rec (mapSnd (maybe_tick toplvl) pairs)
-
-    wrap_one toplvl (FloatLet bind)      = FloatLet (wrap_bind toplvl bind)
-    wrap_one toplvl (FloatCase e b c bs) = FloatCase (maybe_tick toplvl e) b c bs
-
-    maybe_tick :: TopLevelFlag -> CoreExpr -> CoreExpr
-    maybe_tick toplvl e
-        -- We must take care not to tick top-level literal
-        -- strings as this violated the Core invariants. See Note [CoreSyn
-        -- top-level string literals].
-      | isTopLevel toplvl && exprIsLiteralString e = e
-      | exprIsHNF e = tickHNFArgs t e
-      | otherwise   = mkTick t e
+    wrap_defns = mapBag wrap_one
+
+    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)
+
+    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
+
+    maybe_tick e | exprIsHNF e = tickHNFArgs t e
+                 | otherwise   = mkTick t e
       -- we don't need to wrap a tick around an HNF when we float it
       -- outside a tick: that is an invariant of the tick semantics
       -- Conversely, inlining of HNFs inside an SCC is allowed, and
diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs
index 1776db51fd..b484de3bc3 100644
--- a/compiler/simplCore/LiberateCase.hs
+++ b/compiler/simplCore/LiberateCase.hs
@@ -9,9 +9,12 @@ module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import CoreSyn
 import CoreUnfold       ( couldBeSmallEnoughToInline )
+import TysWiredIn       ( unitDataConId )
 import Id
 import VarEnv
 import Util             ( notNull )
@@ -66,24 +69,6 @@ Exactly the same optimisation (unrolling one call to f) will work here,
 despite the cast.  See mk_alt_env in the Case branch of libCase.
 
 
-Note [Only functions!]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider the following code
-
-       f = g (case v of V a b -> a : t f)
-
-where g is expensive. If we aren't careful, liberate case will turn this into
-
-       f = g (case v of
-               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
-                                in f)
-             )
-
-Yikes! We evaluate g twice. This leads to a O(2^n) explosion
-if g calls back to the same code recursively.
-
-Solution: make sure that we only do the liberate-case thing on *functions*
-
 To think about (Apr 94)
 ~~~~~~~~~~~~~~
 Main worry: duplicating code excessively.  At the moment we duplicate
@@ -154,18 +139,63 @@ libCaseBind env (Rec pairs)
         -- We extend the rec-env by binding each Id to its rhs, first
         -- processing the rhs with an *un-extended* environment, so
         -- that the same process doesn't occur for ever!
-    env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs)
-                              | (binder, rhs) <- pairs
-                              , rhs_small_enough binder rhs ]
+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs
+            | otherwise       = env
+
+    dup_pairs = [ (localiseId binder, libCase env_body rhs)
+                | (binder, rhs) <- pairs ]
         -- localiseID : see Note [Need to localiseId in libCaseBind]
 
+    is_dupable_bind = small_enough && all ok_pair pairs
 
-    rhs_small_enough id rhs     -- Note [Small enough]
-        =  idArity id > 0       -- Note [Only functions!]
-        && maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
-                      (bombOutSize env)
+    -- Size: we are going to duplicate dup_pairs; to find their
+    --       size, build a fake binding (let { dup_pairs } in (),
+    --       and find the size of that
+    -- See Note [Small enough]
+    small_enough = case bombOutSize env of
+                      Nothing   -> True   -- Infinity
+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $
+                                   Let (Rec dup_pairs) (Var unitDataConId)
+
+    ok_pair (id,_)
+        =  idArity id > 0          -- Note [Only functions!]
+        && not (isBottomingId id)  -- Note [Not bottoming ids]
+
+{- Note [Not bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not specialise error-functions (this is unusual, but I once saw it,
+(acually in Data.Typable.Internal)
+
+Note [Only functions!]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider the following code
+
+       f = g (case v of V a b -> a : t f)
+
+where g is expensive. If we aren't careful, liberate case will turn this into
+
+       f = g (case v of
+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
+                                in f)
+             )
+
+Yikes! We evaluate g twice. This leads to a O(2^n) explosion
+if g calls back to the same code recursively.
+
+Solution: make sure that we only do the liberate-case thing on *functions*
+
+Note [Small enough]
+~~~~~~~~~~~~~~~~~~~
+Consider
+  \fv. letrec
+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+         g = \y. SMALL...f...
+
+Then we *can* in principle do liberate-case on 'g' (small RHS) but not
+for 'f' (too big).  But doing so is not profitable, because duplicating
+'g' at its call site in 'f' doesn't get rid of any cases.  So we just
+ask for the whole group to be small enough.
 
-{-
 Note [Need to localiseId in libCaseBind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The call to localiseId is needed for two subtle reasons
@@ -179,16 +209,6 @@ The call to localiseId is needed for two subtle reasons
         nested; if it were floated to the top level, we'd get a name
         clash at code generation time.
 
-Note [Small enough]
-~~~~~~~~~~~~~~~~~~~
-Consider
-  \fv. letrec
-         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
-         g = \y. SMALL...f...
-Then we *can* do liberate-case on g (small RHS) but not for f (too big).
-But we can choose on a item-by-item basis, and that's what the
-rhs_small_enough call in the comprehension for env_rhs does.
-
 Expressions
 ~~~~~~~~~~~
 -}
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 5dd30aa668..236bb81066 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -19,10 +19,13 @@ module OccurAnal (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreFVs
 import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp,
                           stripTicksTopE, mkTicks )
+import CoreArity        ( joinRhsArity )
 import Id
 import IdInfo
 import Name( localiseName )
@@ -56,11 +59,12 @@ import Control.Arrow    ( second )
 Here's the externally-callable interface:
 -}
 
-occurAnalysePgm :: Module       -- Used only in debug output
-                -> (Activation -> Bool)
-                -> [CoreRule] -> [CoreVect] -> VarSet
+occurAnalysePgm :: Module         -- Used only in debug output
+                -> (Id -> Bool)         -- Active unfoldings
+                -> (Activation -> Bool) -- Active rules
+                -> [CoreRule]
                 -> CoreProgram -> CoreProgram
-occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
+occurAnalysePgm this_mod active_unf active_rule imp_rules binds
   | isEmptyDetails final_usage
   = occ_anald_binds
 
@@ -69,7 +73,9 @@ occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
                    2 (ppr final_usage ) )
     occ_anald_glommed_binds
   where
-    init_env = initOccEnv active_rule
+    init_env = initOccEnv { occ_rule_act = active_rule
+                          , occ_unf_act  = active_unf }
+
     (final_usage, occ_anald_binds) = go init_env binds
     (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel
                                                     imp_rule_edges
@@ -80,12 +86,8 @@ occurAnalysePgm this_mod active_rule imp_rules vects vectVars binds
           -- we can easily create an infinite loop (Trac #9583 is an example)
 
     initial_uds = addManyOccsSet emptyDetails
-                            (rulesFreeVars imp_rules `unionVarSet`
-                             vectsFreeVars vects `unionVarSet`
-                             vectVars)
-    -- The RULES and VECTORISE declarations keep things alive! (For VECTORISE declarations,
-    -- we only get them *until* the vectoriser runs. Afterwards, these dependencies are
-    -- reflected in 'vectors' — see Note [Vectorisation declarations and occurrences].)
+                            (rulesFreeVars imp_rules)
+    -- The RULES declarations keep things alive!
 
     -- Note [Preventing loops due to imported functions rules]
     imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv
@@ -118,9 +120,7 @@ occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr
 occurAnalyseExpr' enable_binder_swap expr
   = snd (occAnal env expr)
   where
-    env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap}
-    -- To be conservative, we say that all inlines and rules are active
-    all_active_rules = \_ -> True
+    env = initOccEnv { occ_binder_swap = enable_binder_swap }
 
 {- Note [Plugin rules]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -170,7 +170,7 @@ we treat it like this (occAnalRecBind):
 
 4. To do so we form a new set of Nodes, with the same details, but
    different edges, the "loop-breaker nodes". The loop-breaker nodes
-   have both more and fewer depedencies than the scope edges
+   have both more and fewer dependencies than the scope edges
    (see Note [Choosing loop breakers])
 
    More edges: if f calls g, and g has an active rule that mentions h
@@ -698,39 +698,6 @@ costs us anything when, for some `j`:
 This appears to be very rare in practice. TODO Perhaps we should gather
 statistics to be sure.
 
-Note [Excess polymorphism and join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In principle, if a function would be a join point except that it fails
-the polymorphism rule (see Note [The polymorphism rule of join points] in
-CoreSyn), it can still be made a join point with some effort. This is because
-all tail calls must return the same type (they return to the same context!), and
-thus if the return type depends on an argument, that argument must always be the
-same.
-
-For instance, consider:
-
-  let f :: forall a. a -> Char -> [a]
-      f @a x c = ... f @a x 'a' ...
-  in ... f @Int 1 'b' ... f @Int 2 'c' ...
-
-(where the calls are tail calls). `f` fails the polymorphism rule because its
-return type is [a], where [a] is bound. But since the type argument is always
-'Int', we can rewrite it as:
-
-  let f' :: Int -> Char -> [Int]
-      f' x c = ... f' x 'a' ...
-  in ... f' 1 'b' ... f 2 'c' ...
-
-and now we can make f' a join point:
-
-  join f' :: Int -> Char -> [Int]
-       f' x c = ... jump f' x 'a' ...
-  in ... jump f' 1 'b' ... jump f' 2 'c' ...
-
-It's not clear that this comes up often, however. TODO: Measure how often and
-add this analysis if necessary.
-
 ------------------------------------------------------------
 Note [Adjusting right-hand sides]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -801,7 +768,7 @@ occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage
   = (body_usage, [])
 
   | otherwise                   -- It's mentioned in the body
-  = (body_usage' +++ rhs_usage', [NonRec tagged_binder rhs'])
+  = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs'])
   where
     (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder
     mb_join_arity = willBeJoinId_maybe tagged_binder
@@ -816,16 +783,17 @@ occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage
     -- Unfoldings
     -- See Note [Unfoldings and join points]
     rhs_usage2 = case occAnalUnfolding env NonRecursive binder of
-                   Just unf_usage -> rhs_usage1 +++ unf_usage
+                   Just unf_usage -> rhs_usage1 `andUDs` unf_usage
                    Nothing        -> rhs_usage1
 
     -- Rules
     -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
     rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder
-    rhs_usage3 = rhs_usage2 +++ combineUsageDetailsList
-                                  (map (\(_, l, r) -> l +++ r) rules_w_uds)
-    rhs_usage4 = maybe rhs_usage3 (addManyOccsSet rhs_usage3) $
-                 lookupVarEnv imp_rule_edges binder
+    rule_uds    = map (\(_, l, r) -> l `andUDs` r) rules_w_uds
+    rhs_usage3 = foldr andUDs rhs_usage2 rule_uds
+    rhs_usage4 = case lookupVarEnv imp_rule_edges binder of
+                   Nothing -> rhs_usage3
+                   Just vs -> addManyOccsSet rhs_usage3 vs
        -- See Note [Preventing loops due to imported functions rules]
 
     -- Final adjustment
@@ -835,7 +803,7 @@ occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage
 occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
                -> UsageDetails -> (UsageDetails, [CoreBind])
 occAnalRecBind env lvl imp_rule_edges pairs body_usage
-  = foldr (occAnalRec lvl) (body_usage, []) sccs
+  = foldr (occAnalRec env lvl) (body_usage, []) sccs
         -- For a recursive group, we
         --      * occ-analyse all the RHSs
         --      * compute strongly-connected components
@@ -862,20 +830,20 @@ calls for the purpose of finding join points.
 -}
 
 -----------------------------
-occAnalRec :: TopLevelFlag
+occAnalRec :: OccEnv -> TopLevelFlag
            -> SCC Details
            -> (UsageDetails, [CoreBind])
            -> (UsageDetails, [CoreBind])
 
         -- The NonRec case is just like a Let (NonRec ...) above
-occAnalRec lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
-                               , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))
+occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
+                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))
            (body_uds, binds)
   | not (bndr `usedIn` body_uds)
   = (body_uds, binds)           -- See Note [Dead code]
 
   | otherwise                   -- It's mentioned in the body
-  = (body_uds' +++ rhs_uds',
+  = (body_uds' `andUDs` rhs_uds',
      NonRec tagged_bndr rhs : binds)
   where
     (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr
@@ -885,7 +853,7 @@ occAnalRec lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
         -- The Rec case is the interesting one
         -- See Note [Recursive bindings: the grand plan]
         -- See Note [Loop breaking]
-occAnalRec lvl (CyclicSCC details_s) (body_uds, binds)
+occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)
   | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
   = (body_uds, binds)                   -- See Note [Dead code]
 
@@ -904,7 +872,7 @@ occAnalRec lvl (CyclicSCC details_s) (body_uds, binds)
     final_uds :: UsageDetails
     loop_breaker_nodes :: [LetrecNode]
     (final_uds, loop_breaker_nodes)
-      = mkLoopBreakerNodes lvl bndr_set body_uds details_s
+      = mkLoopBreakerNodes env lvl bndr_set body_uds details_s
 
     ------------------------------
     weak_fvs :: VarSet
@@ -955,7 +923,8 @@ recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
 
 -- Return the bindings sorted into a plausible order, and marked with loop breakers.
 loopBreakNodes depth bndr_set weak_fvs nodes binds
-  = go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds
+  = -- pprTrace "loopBreakNodes" (ppr nodes) $
+    go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds
   where
     go []         binds = binds
     go (scc:sccs) binds = loop_break_scc scc (go sccs binds)
@@ -972,8 +941,8 @@ reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding
 reOrderNodes _ _ _ []     _     = panic "reOrderNodes"
 reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds
 reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
-  = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$
-    --                           text "chosen" <+> ppr chosen_nodes) $
+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen
+    --                              , text "chosen" <+> ppr chosen_nodes ]) $
     loopBreakNodes new_depth bndr_set weak_fvs unchosen $
     (map mk_loop_breaker chosen_nodes ++ binds)
   where
@@ -1243,11 +1212,11 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
     (bndrs, body) = collectBinders rhs
     (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body
     rhs' = mkLams bndrs' body'
-    rhs_usage2 = rhs_usage1 +++ all_rule_uds
+    rhs_usage2 = foldr andUDs rhs_usage1 rule_uds
                    -- Note [Rules are extra RHSs]
                    -- Note [Rule dependency info]
     rhs_usage3 = case mb_unf_uds of
-                   Just unf_uds -> rhs_usage2 +++ unf_uds
+                   Just unf_uds -> rhs_usage2 `andUDs` unf_uds
                    Nothing      -> rhs_usage2
     node_fvs = udFreeVars bndr_set rhs_usage3
 
@@ -1263,8 +1232,7 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
       -- See Note [Preventing loops due to imported functions rules]
                       [ (ru_act rule, udFreeVars bndr_set rhs_uds)
                       | (rule, _, rhs_uds) <- rules_w_uds ]
-    all_rule_uds = combineUsageDetailsList $
-                     concatMap (\(_, l, r) -> [l, r]) rules_w_uds
+    rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds
     active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs
                                         , is_active a]
 
@@ -1280,7 +1248,7 @@ makeNode env imp_rule_edges bndr_set (bndr, rhs)
                       -- isn't the right thing (it tells about
                       -- RULE activation), so we'd need more plumbing
 
-mkLoopBreakerNodes :: TopLevelFlag
+mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
                    -> VarSet
                    -> UsageDetails   -- for BODY of let
                    -> [Details]
@@ -1293,7 +1261,7 @@ mkLoopBreakerNodes :: TopLevelFlag
 --      the loop-breaker SCC analysis
 --   d) adjust each RHS's usage details according to
 --      the binder's (new) shotness and join-point-hood
-mkLoopBreakerNodes lvl bndr_set body_uds details_s
+mkLoopBreakerNodes env lvl bndr_set body_uds details_s
   = (final_uds, zipWith mk_lb_node details_s bndrs')
   where
     (final_uds, bndrs') = tagRecBinders lvl body_uds
@@ -1309,7 +1277,7 @@ mkLoopBreakerNodes lvl bndr_set body_uds details_s
               -- Note [Deterministic SCC] in Digraph.
       where
         nd'     = nd { nd_bndr = bndr', nd_score = score }
-        score   = nodeScore bndr bndr' rhs lb_deps
+        score   = nodeScore env bndr bndr' rhs lb_deps
         lb_deps = extendFvs_ rule_fv_env inl_fvs
 
     rule_fv_env :: IdEnv IdSet
@@ -1325,18 +1293,22 @@ mkLoopBreakerNodes lvl bndr_set body_uds details_s
 
 
 ------------------------------------------
-nodeScore :: Id        -- Binder has old occ-info (just for loop-breaker-ness)
+nodeScore :: OccEnv
+          -> Id        -- Binder has old occ-info (just for loop-breaker-ness)
           -> Id        -- Binder with new occ-info
           -> CoreExpr  -- RHS
           -> VarSet    -- Loop-breaker dependencies
           -> NodeScore
-nodeScore old_bndr new_bndr bind_rhs lb_deps
+nodeScore env old_bndr new_bndr bind_rhs lb_deps
   | not (isId old_bndr)     -- A type or cercion variable is never a loop breaker
   = (100, 0, False)
 
   | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers
   = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]
 
+  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has
+  = (0, 0, True)                   -- a NOINLINE pragam) makes a great loop breaker
+
   | exprIsTrivial rhs
   = mk_score 10  -- Practically certain to be inlined
     -- Used to have also: && not (isExportedId bndr)
@@ -1553,19 +1525,24 @@ occAnalNonRecRhs :: OccEnv
 occAnalNonRecRhs env bndr bndrs body
   = occAnalLamOrRhs rhs_env bndrs body
   where
-    -- See Note [Cascading inlines]
-    env1 | certainly_inline = env
+    env1 | is_join_point    = env  -- See Note [Join point RHSs]
+         | certainly_inline = env  -- See Note [Cascading inlines]
          | otherwise        = rhsCtxt env
 
     -- See Note [Sources of one-shot information]
     rhs_env = env1 { occ_one_shots = argOneShots dmd }
 
     certainly_inline -- See Note [Cascading inlines]
-      = case idOccInfo bndr of
+      = case occ of
           OneOcc { occ_in_lam = in_lam, occ_one_br = one_br }
-                                 -> not in_lam && one_br && active && not_stable
-          _                      -> False
+            -> not in_lam && one_br && active && not_stable
+          _ -> False
+
+    is_join_point = isAlwaysTailCalled occ
+    -- Like (isJoinId bndr) but happens one step earlier
+    --  c.f. willBeJoinId_maybe
 
+    occ        = idOccInfo bndr
     dmd        = idDemandInfo bndr
     active     = isAlwaysActive (idInlineActivation bndr)
     not_stable = not (isStableUnfolding (idUnfolding bndr))
@@ -1591,7 +1568,7 @@ occAnalUnfolding env rec_flag id
       DFunUnfolding { df_bndrs = bndrs, df_args = args }
         -> Just $ zapDetails (delDetailsList usage bndrs)
         where
-          usage = foldr (+++) emptyDetails (map (fst . occAnal env) args)
+          usage = andUDsList (map (fst . occAnal env) args)
 
       _ -> Nothing
 
@@ -1626,7 +1603,18 @@ occAnalRules env mb_expected_join_arity rec_flag id
       = case mb_expected_join_arity of
           Just ar | args `lengthIs` ar -> uds
           _                            -> markAllNonTailCalled uds
-{-
+{- Note [Join point RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   x = e
+   join j = Just x
+
+We want to inline x into j right away, so we don't want to give
+the join point a RhsCtxt (Trac #14137).  It's not a huge deal, because
+the FloatIn pass knows to float into join point RHSs; and the simplifier
+does not float things out of join point RHSs.  But it's a simple, cheap
+thing to do.  See Trac #14137.
+
 Note [Cascading inlines]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 By default we use an rhsCtxt for the RHS of a binding.  This tells the
@@ -1653,15 +1641,19 @@ definitely inline the next time round, and so we analyse x3's rhs in
 an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.
 
 Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally.
-If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
-indefinitely:
+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and
+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"
+then the simplifier iterates indefinitely:
         x = f y
-        k = Just x
+        k = Just x   -- We decide that k is 'certainly_inline'
+        v = ...k...  -- but preInlineUnconditionally doesn't inline it
 inline ==>
         k = Just (f y)
+        v = ...k...
 float ==>
         x1 = f y
         k = Just x1
+        v = ...k...
 
 This is worse than the slow cascade, so we only want to say "certainly_inline"
 if it really is certain.  Look at the note with preInlineUnconditionally
@@ -1702,11 +1694,17 @@ we can sort them into the right place when doing dependency analysis.
 -}
 
 occAnal env (Tick tickish body)
+  | SourceNote{} <- tickish
+  = (usage, Tick tickish body')
+                  -- SourceNotes are best-effort; so we just proceed as usual.
+                  -- If we drop a tick due to the issues described below it's
+                  -- not the end of the world.
+
   | tickish `tickishScopesLike` SoftScope
   = (markAllNonTailCalled usage, Tick tickish body')
 
   | Breakpoint _ ids <- tickish
-  = (usage_lam +++ foldr addManyOccs emptyDetails ids, Tick tickish body')
+  = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body')
     -- never substitute for any of the Ids in a Breakpoint
 
   | otherwise
@@ -1721,16 +1719,17 @@ occAnal env (Tick tickish body)
                   -- Making j a join point may cause the simplifier to drop t
                   -- (if the tick is put into the continuation). So we don't
                   -- count j 1 as a tail call.
+                  -- See #14242.
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
     let usage1 = zapDetailsIf (isRhsEnv env) usage
+          -- usage1: if we see let x = y `cast` co
+          -- then mark y as 'Many' so that we don't
+          -- immediately inline y again.
         usage2 = addManyOccsSet usage1 (coVarsOfCo co)
-          -- See Note [Gather occurrences of coercion variables]
+          -- usage2: see Note [Gather occurrences of coercion variables]
     in (markAllNonTailCalled usage2, Cast expr' co)
-        -- If we see let x = y `cast` co
-        -- then mark y as 'Many' so that we don't
-        -- immediately inline y again.
     }
 
 occAnal env app@(App _ _)
@@ -1772,30 +1771,13 @@ occAnal env (Case scrut bndr ty alts)
   = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->
     case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
     let
-        alts_usage  = foldr combineAltsUsageDetails emptyDetails alts_usage_s
-        (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
-        total_usage = markAllNonTailCalled scrut_usage +++ alts_usage1
+        alts_usage  = foldr orUDs emptyDetails alts_usage_s
+        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
+        total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1
                         -- Alts can have tail calls, but the scrutinee can't
     in
     total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
   where
-        -- Note [Case binder usage]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~
-        -- The case binder gets a usage of either "many" or "dead", never "one".
-        -- Reason: we like to inline single occurrences, to eliminate a binding,
-        -- but inlining a case binder *doesn't* eliminate a binding.
-        -- We *don't* want to transform
-        --      case x of w { (p,q) -> f w }
-        -- into
-        --      case x of w { (p,q) -> f (p,q) }
-    tag_case_bndr usage bndr
-      = (usage', setIdOccInfo bndr final_occ_info)
-      where
-        occ_info       = lookupDetails usage bndr
-        usage'         = usage `delDetails` bndr
-        final_occ_info = case occ_info of IAmDead -> IAmDead
-                                          _       -> noOccInfo
-
     alt_env = mkAltEnv env scrut bndr
     occ_anal_alt = occAnalAlt alt_env
 
@@ -1834,7 +1816,7 @@ occAnalArgs env (arg:args) one_shots
   = case argCtxt env one_shots           of { (arg_env, one_shots') ->
     case occAnal arg_env arg             of { (uds1, arg') ->
     case occAnalArgs env args one_shots' of { (uds2, args') ->
-    (uds1 +++ uds2, arg':args') }}}
+    (uds1 `andUDs` uds2, arg':args') }}}
 
 {-
 Applications are dealt with specially because we want
@@ -1860,7 +1842,7 @@ occAnalApp env (Var fun, args, ticks)
   | null ticks = (uds, mkApps (Var fun) args')
   | otherwise  = (uds, mkTicks ticks $ mkApps (Var fun) args')
   where
-    uds = fun_uds +++ final_args_uds
+    uds = fun_uds `andUDs` final_args_uds
 
     !(args_uds, args') = occAnalArgs env args one_shots
     !final_args_uds
@@ -1890,7 +1872,7 @@ occAnalApp env (Var fun, args, ticks)
         -- See Note [Sources of one-shot information], bullet point A']
 
 occAnalApp env (fun, args, ticks)
-  = (markAllNonTailCalled (fun_uds +++ args_uds),
+  = (markAllNonTailCalled (fun_uds `andUDs` args_uds),
      mkTicks ticks $ mkApps fun' args')
   where
     !(fun_uds, fun') = occAnal (addAppCtxt env args) fun
@@ -2024,10 +2006,9 @@ occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
 occAnalAlt (env, scrut_bind) (con, bndrs, rhs)
   = case occAnal env rhs of { (rhs_usage1, rhs1) ->
     let
-        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
-                                  -- See Note [Binders in case alternatives]
-        (alt_usg', rhs2) =
-          wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
+      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
+                                -- See Note [Binders in case alternatives]
+      (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
     in
     (alt_usg', (con, tagged_bndrs, rhs2)) }
 
@@ -2042,15 +2023,19 @@ wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
   , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this
                                -- handles condition (a) in Note [Binder swap]
   , not captured               -- See condition (b) in Note [Binder swap]
-  = ( alt_usg' +++ let_rhs_usg
+  = ( alt_usg' `andUDs` let_rhs_usg
     , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )
   where
-    captured = any (`usedIn` let_rhs_usg) bndrs
+    captured = any (`usedIn` let_rhs_usg) bndrs  -- Check condition (b)
+
     -- The rhs of the let may include coercion variables
     -- if the scrutinee was a cast, so we must gather their
     -- usage. See Note [Gather occurrences of coercion variables]
+    -- Moreover, the rhs of the let may mention the case-binder, and
+    -- we want to gather its occ-info as well
     (let_rhs_usg, let_rhs') = occAnal env let_rhs
-    (alt_usg', [tagged_scrut_var]) = tagLamBinders alt_usg [scrut_var]
+
+    (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var
 
 wrapAltRHS _ _ alt_usg _ alt_rhs
   = (alt_usg, alt_rhs)
@@ -2067,8 +2052,12 @@ data OccEnv
   = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information
            , occ_one_shots  :: !OneShots     -- See Note [OneShots]
            , occ_gbl_scrut  :: GlobalScruts
+
+           , occ_unf_act   :: Id -> Bool   -- Which Id unfoldings are active
+
            , occ_rule_act   :: Activation -> Bool   -- Which rules are active
              -- See Note [Finding rule RHS free vars]
+
            , occ_binder_swap :: !Bool -- enable the binder_swap
              -- See CorePrep Note [Dead code in CorePrep]
     }
@@ -2081,7 +2070,7 @@ type GlobalScruts = IdSet   -- See Note [Binder swap on GlobalId scrutinees]
 --      x = (p,q)               -- Don't inline p or q
 --      y = /\a -> (p a, q a)   -- Still don't inline p or q
 --      z = f (p,q)             -- Do inline p,q; it may make a rule fire
--- So OccEncl tells enought about the context to know what to do when
+-- So OccEncl tells enough about the context to know what to do when
 -- we encounter a constructor application or PAP.
 
 data OccEncl
@@ -2097,12 +2086,15 @@ instance Outputable OccEncl where
 -- See note [OneShots]
 type OneShots = [OneShotInfo]
 
-initOccEnv :: (Activation -> Bool) -> OccEnv
-initOccEnv active_rule
+initOccEnv :: OccEnv
+initOccEnv
   = OccEnv { occ_encl      = OccVanilla
            , occ_one_shots = []
            , occ_gbl_scrut = emptyVarSet
-           , occ_rule_act  = active_rule
+                 -- To be conservative, we say that all
+                 -- inlines and rules are active
+           , occ_unf_act   = \_ -> True
+           , occ_rule_act  = \_ -> True
            , occ_binder_swap = True }
 
 vanillaCtxt :: OccEnv -> OccEnv
@@ -2160,7 +2152,12 @@ markJoinOneShots mb_join_arity bndrs
       Just n  -> go n bndrs
  where
    go 0 bndrs  = bndrs
-   go _ []     = WARN( True, ppr mb_join_arity <+> ppr bndrs ) []
+   go _ []     = [] -- This can legitimately happen.
+                    -- e.g.    let j = case ... in j True
+                    -- This will become an arity-1 join point after the
+                    -- simplifier has eta-expanded it; but it may not have
+                    -- enough lambdas /yet/. (Lint checks that JoinIds do
+                    -- have enough lambdas.)
    go n (b:bs) = b' : go (n-1) bs
      where
        b' | isId b    = setOneShotLambda b
@@ -2298,6 +2295,9 @@ Core Lint never expects to find an *occurrence* of an Id marked
 as Dead, so we must zap the OccInfo on cb before making the
 binding x = cb.  See Trac #5028.
 
+NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier
+doesn't use it. So this is only to satisfy the perhpas-over-picky Lint.
+
 Historical note [no-case-of-case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We *used* to suppress the binder-swap in case expressions when
@@ -2361,10 +2361,10 @@ information right.
 -}
 
 mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
--- Does two things: a) makes the occ_one_shots = OccVanilla
---                  b) extends the GlobalScruts if possible
---                  c) returns a proxy mapping, binding the scrutinee
---                     to the case binder, if possible
+-- Does three things: a) makes the occ_one_shots = OccVanilla
+--                    b) extends the GlobalScruts if possible
+--                    c) returns a proxy mapping, binding the scrutinee
+--                       to the case binder, if possible
 mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
   = case stripTicksTopE (const True) scrut of
       Var v           -> add_scrut v case_bndr'
@@ -2373,15 +2373,19 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
       _               -> (env { occ_encl = OccVanilla }, Nothing)
 
   where
-    add_scrut v rhs = ( env { occ_encl = OccVanilla, occ_gbl_scrut = pe `extendVarSet` v }
+    add_scrut v rhs = ( env { occ_encl = OccVanilla
+                            , occ_gbl_scrut = pe `extendVarSet` v }
                       , Just (localise v, rhs) )
 
-    case_bndr' = Var (zapIdOccInfo case_bndr) -- See Note [Zap case binders in proxy bindings]
-    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) (idType scrut_var)
-        -- Localise the scrut_var before shadowing it; we're making a
-        -- new binding for it, and it might have an External Name, or
-        -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
-        -- Also we don't want any INLINE or NOINLINE pragmas!
+    case_bndr' = Var (zapIdOccInfo case_bndr)
+                   -- See Note [Zap case binders in proxy bindings]
+
+    -- Localise the scrut_var before shadowing it; we're making a
+    -- new binding for it, and it might have an External Name, or
+    -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
+    -- Also we don't want any INLINE or NOINLINE pragmas!
+    localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var))
+                                          (idType scrut_var)
 
 {-
 ************************************************************************
@@ -2426,13 +2430,13 @@ instance Outputable UsageDetails where
 -------------------
 -- UsageDetails API
 
-(+++), combineAltsUsageDetails
+andUDs, orUDs
         :: UsageDetails -> UsageDetails -> UsageDetails
-(+++) = combineUsageDetailsWith addOccInfo
-combineAltsUsageDetails = combineUsageDetailsWith orOccInfo
+andUDs = combineUsageDetailsWith addOccInfo
+orUDs  = combineUsageDetailsWith orOccInfo
 
-combineUsageDetailsList :: [UsageDetails] -> UsageDetails
-combineUsageDetailsList = foldl (+++) emptyDetails
+andUDsList :: [UsageDetails] -> UsageDetails
+andUDsList = foldl' andUDs emptyDetails
 
 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
 mkOneOcc env id int_cxt arity
@@ -2581,14 +2585,21 @@ tagLamBinders :: UsageDetails          -- Of scope
               -> [Id]                  -- Binders
               -> (UsageDetails,        -- Details with binders removed
                  [IdWithOccInfo])    -- Tagged binders
+tagLamBinders usage binders
+  = usage' `seq` (usage', bndrs')
+  where
+    (usage', bndrs') = mapAccumR tagLamBinder usage binders
+
+tagLamBinder :: UsageDetails       -- Of scope
+             -> Id                 -- Binder
+             -> (UsageDetails,     -- Details with binder removed
+                 IdWithOccInfo)    -- Tagged binders
 -- Used for lambda and case binders
 -- It copes with the fact that lambda bindings can have a
 -- stable unfolding, used for join points
-tagLamBinders usage binders = usage' `seq` (usage', bndrs')
+tagLamBinder usage bndr
+  = (usage2, bndr')
   where
-    (usage', bndrs') = mapAccumR tag_lam usage binders
-    tag_lam usage bndr = (usage2, bndr')
-      where
         occ    = lookupDetails usage bndr
         bndr'  = setBinderOcc (markNonTailCalled occ) bndr
                    -- Don't try to make an argument into a join point
@@ -2633,7 +2644,7 @@ tagRecBinders lvl body_uds triples
 
      -- 1. Determine join-point-hood of whole group, as determined by
      --    the *unadjusted* usage details
-     unadj_uds     = body_uds +++ combineUsageDetailsList rhs_udss
+     unadj_uds     = foldr andUDs body_uds rhs_udss
      will_be_joins = decideJoinPointHood lvl unadj_uds bndrs
 
      -- 2. Adjust usage details of each RHS, taking into account the
@@ -2650,19 +2661,15 @@ tagRecBinders lvl body_uds triples
            , AlwaysTailCalled arity <- tailCallInfo occ
            = Just arity
            | otherwise
-           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if we're
-                                       -- making join points!
-             Nothing
+           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if
+             Nothing                   -- we are making join points!
 
      -- 3. Compute final usage details from adjusted RHS details
-     adj_uds   = body_uds +++ combineUsageDetailsList rhs_udss'
+     adj_uds   = foldr andUDs body_uds rhs_udss'
 
-     -- 4. Tag each binder with its adjusted details modulo the
-     --    join-point-hood decision
-     occs      = map (lookupDetails adj_uds) bndrs
-     occs'     | will_be_joins = occs
-               | otherwise     = map markNonTailCalled occs
-     bndrs'    = zipWith setBinderOcc occs' bndrs
+     -- 4. Tag each binder with its adjusted details
+     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr
+                 | bndr <- bndrs ]
 
      -- 5. Drop the binders from the adjusted details and return
      usage'    = adj_uds `delDetailsList` bndrs
@@ -2683,10 +2690,15 @@ setBinderOcc occ_info bndr
 
 -- | Decide whether some bindings should be made into join points or not.
 -- Returns `False` if they can't be join points. Note that it's an
--- all-or-nothing decision, as if multiple binders are given, they're assumed to
--- be mutually recursive.
+-- all-or-nothing decision, as if multiple binders are given, they're
+-- assumed to be mutually recursive.
+--
+-- It must, however, be a final decision. If we say "True" for 'f',
+-- and then subsequently decide /not/ make 'f' into a join point, then
+-- the decision about another binding 'g' might be invalidated if (say)
+-- 'f' tail-calls 'g'.
 --
--- See Note [Invariants for join points] in CoreSyn.
+-- See Note [Invariants on join points] in CoreSyn.
 decideJoinPointHood :: TopLevelFlag -> UsageDetails
                     -> [CoreBndr]
                     -> Bool
@@ -2708,11 +2720,18 @@ decideJoinPointHood NotTopLevel usage bndrs
     ok bndr
       | -- Invariant 1: Only tail calls, all same join arity
         AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)
+
       , -- Invariant 1 as applied to LHSes of rules
         all (ok_rule arity) (idCoreRules bndr)
+
+        -- Invariant 2a: stable unfoldings
+        -- See Note [Join points and INLINE pragmas]
+      , ok_unfolding arity (realIdUnfolding bndr)
+
         -- Invariant 4: Satisfies polymorphism rule
       , isValidJoinPointType arity (idType bndr)
       = True
+
       | otherwise
       = False
 
@@ -2721,14 +2740,52 @@ decideJoinPointHood NotTopLevel usage bndrs
       = args `lengthIs` join_arity
         -- Invariant 1 as applied to LHSes of rules
 
+    -- ok_unfolding returns False if we should /not/ convert a non-join-id
+    -- into a join-id, even though it is AlwaysTailCalled
+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })
+      = not (isStableSource src && join_arity > joinRhsArity rhs)
+    ok_unfolding _ (DFunUnfolding {})
+      = False
+    ok_unfolding _ _
+      = True
+
 willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
 willBeJoinId_maybe bndr
-  | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
-  = Just arity
-  | otherwise
-  = isJoinId_maybe bndr
+  = case tailCallInfo (idOccInfo bndr) of
+      AlwaysTailCalled arity -> Just arity
+      _                      -> isJoinId_maybe bndr
+
+
+{- Note [Join points and INLINE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = let g = \x. not  -- Arity 1
+             {-# INLINE g #-}
+         in case x of
+              A -> g True True
+              B -> g True False
+              C -> blah2
+
+Here 'g' is always tail-called applied to 2 args, but the stable
+unfolding captured by the INLINE pragma has arity 1.  If we try to
+convert g to be a join point, its unfolding will still have arity 1
+(since it is stable, and we don't meddle with stable unfoldings), and
+Lint will complain (see Note [Invariants on join points], (2a), in
+CoreSyn.  Trac #13413.
+
+Moreover, since g is going to be inlined anyway, there is no benefit
+from making it a join point.
+
+If it is recursive, and uselessly marked INLINE, this will stop us
+making it a join point, which is annoying.  But occasionally
+(notably in class methods; see Note [Instances and loop breakers] in
+TcInstDcls) we mark recursive things as INLINE but the recursion
+unravels; so ignoring INLINE pragmas on recursive things isn't good
+either.
+
+See Invariant 2a of Note [Invariants on join points] in CoreSyn
+
 
-{-
 ************************************************************************
 *                                                                      *
 \subsection{Operations over OccInfo}
@@ -2762,10 +2819,11 @@ orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1
                   , occ_tail   = tail1 })
           (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2
                   , occ_tail   = tail2 })
-  = OneOcc { occ_in_lam  = in_lam1 || in_lam2
-           , occ_one_br  = False -- False, because it occurs in both branches
+  = OneOcc { occ_one_br  = False -- False, because it occurs in both branches
+           , occ_in_lam  = in_lam1 || in_lam2
            , occ_int_cxt = int_cxt1 && int_cxt2
            , occ_tail    = tail1 `andTailCallInfo` tail2 }
+
 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                   ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`
                                         tailCallInfo a2 }
diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs
index 923d3a4209..e9a62d530d 100644
--- a/compiler/simplCore/SAT.hs
+++ b/compiler/simplCore/SAT.hs
@@ -51,6 +51,8 @@ essential to make this work well!
 {-# LANGUAGE CPP #-}
 module SAT ( doStaticArgs ) where
 
+import GhcPrelude
+
 import Var
 import CoreSyn
 import CoreUtils
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 2b533b73bd..b8212c72f3 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -62,6 +62,8 @@ module SetLevels (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType, exprIsHNF
@@ -79,12 +81,14 @@ import Id
 import IdInfo
 import Var
 import VarSet
+import UniqSet          ( nonDetFoldUniqSet )
 import VarEnv
 import Literal          ( litIsTrivial )
 import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
 import Name             ( getOccName, mkSystemVarName )
 import OccName          ( occNameString )
-import Type             ( Type, mkLamTypes, splitTyConApp_maybe )
+import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType )
+import TyCoRep          ( closeOverKindsDSet )
 import BasicTypes       ( Arity, RecFlag(..), isRec )
 import DataCon          ( dataConOrigResTy )
 import TysWiredIn
@@ -120,7 +124,7 @@ data FloatSpec
   = FloatMe Level       -- Float to just inside the binding
                         --    tagged with this level
   | StayPut Level       -- Stay where it is; binding is
-                        --     tagged with tihs level
+                        --     tagged with this level
 
 floatSpecLevel :: FloatSpec -> Level
 floatSpecLevel (FloatMe l) = l
@@ -399,13 +403,13 @@ lvlApp env orig_expr ((_,AnnVar fn), args)
   , Nothing <- isClassOpId_maybe fn
   =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs
         ; lapp'  <- lvlNonTailMFE env False lapp
-        ; return (foldl App lapp' rargs') }
+        ; return (foldl' App lapp' rargs') }
 
   | otherwise
   = do { (_, args') <- mapAccumLM lvl_arg stricts args
             -- Take account of argument strictness; see
             -- Note [Floating to the top]
-       ; return (foldl App (lookupVar env fn) args') }
+       ; return (foldl' App (lookupVar env fn) args') }
   where
     n_val_args = count (isValArg . deAnnotate) args
     arity      = idArity fn
@@ -446,7 +450,7 @@ lvlApp env _ (fun, args)
      -- arguments and the function.
      do { args' <- mapM (lvlNonTailMFE env False) args
         ; fun'  <- lvlNonTailExpr env fun
-        ; return (foldl App fun' args') }
+        ; return (foldl' App fun' args') }
 
 -------------------------------------------
 lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
@@ -457,7 +461,8 @@ lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
         -> LvlM LevelledExpr    -- Result expression
 lvlCase env scrut_fvs scrut' case_bndr ty alts
   | [(con@(DataAlt {}), bs, body)] <- alts
-  , exprOkForSpeculation scrut'   -- See Note [Check the output scrutinee for okForSpec]
+  , exprOkForSpeculation (deTagExpr scrut')
+                                  -- See Note [Check the output scrutinee for okForSpec]
   , not (isTopLvl dest_lvl)       -- Can't have top-level cases
   , not (floatTopLvlOnly env)     -- Can float anywhere
   =     -- See Note [Floating cases]
@@ -528,7 +533,7 @@ okForSpeculation we must be careful to test the *result* scrutinee ('x'
 in this case), not the *input* one 'y'.  The latter *is* ok for
 speculation here, but the former is not -- and indeed we can't float
 the inner case out, at least not unless x is also evaluated at its
-binding site.
+binding site.  See Trac #5453.
 
 That's why we apply exprOkForSpeculation to scrut' and not to scrut.
 -}
@@ -557,7 +562,8 @@ lvlMFE env _ (_, AnnType ty)
 -- and then inline lvl.  Better just to float out the payload.
 lvlMFE env strict_ctxt (_, AnnTick t e)
   = do { e' <- lvlMFE env strict_ctxt e
-       ; return (Tick t e') }
+       ; let t' = substTickish (le_subst env) t
+       ; return (Tick t' e') }
 
 lvlMFE env strict_ctxt (_, AnnCast e (_, co))
   = do  { e' <- lvlMFE env strict_ctxt e
@@ -625,13 +631,14 @@ lvlMFE env strict_ctxt ann_expr
     expr         = deAnnotate ann_expr
     expr_ty      = exprType expr
     fvs          = freeVarsOf ann_expr
+    fvs_ty       = tyCoVarsOfType expr_ty
     is_bot       = isBottomThunk mb_bot_str
     is_function  = isFunction ann_expr
     mb_bot_str   = exprBotStrictness_maybe expr
                            -- See Note [Bottoming floats]
                            -- esp Bottoming floats (2)
     expr_ok_for_spec = exprOkForSpeculation expr
-    dest_lvl     = destLevel env fvs is_function is_bot False
+    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False
     abs_vars     = abstractVars dest_lvl env fvs
 
     -- float_is_new_lam: the floated thing will be a new value lambda
@@ -1024,7 +1031,7 @@ lvlBind env (AnnNonRec bndr rhs)
   || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
                     -- so we will ignore this case for now
   || not (profitableFloat env dest_lvl)
-  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs (idType bndr)))
+  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
           -- We can't float an unlifted binding to top level (except
           -- literal strings), so we don't float it at all.  It's a
           -- bit brutal, but unlifted bindings aren't expensive either
@@ -1053,10 +1060,12 @@ lvlBind env (AnnNonRec bndr rhs)
        ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
 
   where
+    bndr_ty    = idType bndr
+    ty_fvs     = tyCoVarsOfType bndr_ty
     rhs_fvs    = freeVarsOf rhs
     bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
     abs_vars   = abstractVars dest_lvl env bind_fvs
-    dest_lvl   = destLevel env bind_fvs (isFunction rhs) is_bot is_join
+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
 
     deann_rhs  = deAnnotate rhs
     mb_bot_str = exprBotStrictness_maybe deann_rhs
@@ -1147,7 +1156,8 @@ lvlBind env (AnnRec pairs)
                `delDVarSetList`
                 bndrs
 
-    dest_lvl = destLevel env bind_fvs is_fun is_bot is_join
+    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
     abs_vars = abstractVars dest_lvl env bind_fvs
 
 profitableFloat :: LevelEnv -> Level -> Bool
@@ -1260,7 +1270,7 @@ substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
 -- So named only to avoid the name clash with CoreSubst.substBndrs
 substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
   = ( env { le_subst    = subst'
-          , le_env      = foldl add_id  id_env (bndrs `zip` bndrs') }
+          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }
     , bndrs')
   where
     (subst', bndrs') = case is_rec of
@@ -1310,13 +1320,16 @@ stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
 
   -- Destination level is the max Id level of the expression
   -- (We'll abstract the type variables, if any.)
-destLevel :: LevelEnv -> DVarSet
+destLevel :: LevelEnv
+          -> DVarSet    -- Free vars of the term
+          -> TyCoVarSet -- Free in the /type/ of the term
+                        -- (a subset of the previous argument)
           -> Bool   -- True <=> is function
           -> Bool   -- True <=> is bottom
           -> Bool   -- True <=> is a join point
           -> Level
 -- INVARIANT: if is_join=True then result >= join_ceiling
-destLevel env fvs is_function is_bot is_join
+destLevel env fvs fvs_ty is_function is_bot is_join
   | isTopLvl max_fv_id_level  -- Float even joins if they get to top level
                               -- See Note [Floating join point bindings]
   = tOP_LEVEL
@@ -1328,21 +1341,48 @@ destLevel env fvs is_function is_bot is_join
     else max_fv_id_level
 
   | is_bot              -- Send bottoming bindings to the top
-  = tOP_LEVEL           -- regardless; see Note [Bottoming floats]
+  = as_far_as_poss      -- regardless; see Note [Bottoming floats]
                         -- Esp Bottoming floats (1)
 
   | Just n_args <- floatLams env
   , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case
   , is_function
   , countFreeIds fvs <= n_args
-  = tOP_LEVEL   -- Send functions to top level; see
-                -- the comments with isFunction
+  = as_far_as_poss  -- Send functions to top level; see
+                    -- the comments with isFunction
 
   | otherwise = max_fv_id_level
   where
-    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the tyvars
-                                              -- will be abstracted
-    join_ceiling = joinCeilingLevel env
+    join_ceiling    = joinCeilingLevel env
+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
+                                              -- tyvars will be abstracted
+
+    as_far_as_poss = maxFvLevel' isId env fvs_ty
+                     -- See Note [Floating and kind casts]
+
+{- Note [Floating and kind casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   case x of
+     K (co :: * ~# k) -> let v :: Int |> co
+                             v = e
+                         in blah
+
+Then, even if we are abstracting over Ids, or if e is bottom, we can't
+float v outside the 'co' binding.  Reason: if we did we'd get
+    v' :: forall k. (Int ~# Age) => Int |> co
+and now 'co' isn't in scope in that type. The underlying reason is
+that 'co' is a value-level thing and we can't abstract over that in a
+type (else we'd get a dependent type).  So if v's /type/ mentions 'co'
+we can't float it out beyond the binding site of 'co'.
+
+That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss
+is just tOP_LEVEL; but occasionally a coercion variable (which is an
+Id) mentioned in type prevents this.
+
+Example Trac #14270 comment:15.
+-}
+
 
 isFunction :: CoreExprWithFVs -> Bool
 -- The idea here is that we want to float *functions* to
@@ -1439,7 +1479,7 @@ addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
 addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
 
 addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
-addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs
+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
 
 floatLams :: LevelEnv -> Maybe Int
 floatLams le = floatOutLambdas (le_switches le)
@@ -1476,14 +1516,20 @@ placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
     lvl' = asJoinCeilLvl (incMinorLvl lvl)
 
 maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
-maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set
-  = foldDVarSet max_in tOP_LEVEL var_set
+maxFvLevel max_me env var_set
+  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
+-- Same but for TyCoVarSet
+maxFvLevel' max_me env var_set
+  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
+maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
+  = case lookupVarEnv id_env in_var of
+      Just (abs_vars, _) -> foldr max_out lvl abs_vars
+      Nothing            -> max_out in_var lvl
   where
-    max_in in_var lvl
-       = foldr max_out lvl (case lookupVarEnv id_env in_var of
-                                Just (abs_vars, _) -> abs_vars
-                                Nothing            -> [in_var])
-
     max_out out_var lvl
         | max_me out_var = case lookupVarEnv lvl_env out_var of
                                 Just lvl' -> maxLvl lvl' lvl
@@ -1513,17 +1559,14 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
         -- Uniques are not deterministic.
 abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
   =  -- NB: sortQuantVars might not put duplicates next to each other
-    map zap $ sortQuantVars $ uniq
-    [out_var | out_fv  <- dVarSetElems (substDVarSet subst in_fvs)
-             , out_var <- dVarSetElems (close out_fv)
-             , abstract_me out_var ]
+    map zap $ sortQuantVars $
+    filter abstract_me      $
+    dVarSetElems            $
+    closeOverKindsDSet      $
+    substDVarSet subst in_fvs
         -- NB: it's important to call abstract_me only on the OutIds the
         -- come from substDVarSet (not on fv, which is an InId)
   where
-    uniq :: [Var] -> [Var]
-        -- Remove duplicates, preserving order
-    uniq = dVarSetElems . mkDVarSet
-
     abstract_me v = case lookupVarEnv lvl_env v of
                         Just lvl -> dest_lvl `ltLvl` lvl
                         Nothing  -> False
@@ -1536,12 +1579,6 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
                      setIdInfo v vanillaIdInfo
           | otherwise = v
 
-    close :: Var -> DVarSet  -- Close over variables free in the type
-                             -- Result includes the input variable itself
-    close v = foldDVarSet (unionDVarSet . close)
-                          (unitDVarSet v)
-                          (fvDVarSet $ varTypeTyCoFVs v)
-
 type LvlM result = UniqSM result
 
 initLvl :: UniqSupply -> UniqSM a -> a
@@ -1559,8 +1596,8 @@ newPolyBndrs dest_lvl
       ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
             bndr_prs  = bndrs `zip` new_bndrs
             env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
-                       , le_subst   = foldl add_subst subst   bndr_prs
-                       , le_env     = foldl add_id    id_env  bndr_prs }
+                       , le_subst   = foldl' add_subst subst   bndr_prs
+                       , le_env     = foldl' add_id    id_env  bndr_prs }
       ; return (env', new_bndrs) }
   where
     add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
@@ -1603,7 +1640,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
       | otherwise
-      = mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty
+      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
 
 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
 cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
@@ -1614,7 +1651,7 @@ cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env
                         , le_join_ceil = new_lvl
                         , le_lvl_env   = addLvls new_lvl lvl_env vs'
                         , le_subst     = subst'
-                        , le_env       = foldl add_id id_env (vs `zip` vs') }
+                        , le_env       = foldl' add_id id_env (vs `zip` vs') }
 
        ; return (env', vs') }
 
@@ -1636,7 +1673,7 @@ cloneLetVars is_rec
              prs  = vs `zip` vs2
              env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
                         , le_subst   = subst'
-                        , le_env     = foldl add_id id_env prs }
+                        , le_env     = foldl' add_id id_env prs }
 
        ; return (env', vs2) }
   where
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index c1513b8af6..168ece971c 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -10,12 +10,15 @@ module SimplCore ( core2core, simplifyExpr ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import CoreSyn
 import HscTypes
 import CSE              ( cseProgram )
 import Rules            ( mkRuleBase, unionRuleBase,
-                          extendRuleBaseList, ruleCheckProgram, addRuleInfo, )
+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
+                          getRules )
 import PprCore          ( pprCoreBindings, pprCoreExpr )
 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
@@ -24,7 +27,7 @@ import CoreUtils        ( mkTicks, stripTicksTop )
 import CoreLint         ( endPass, lintPassResult, dumpPassResult,
                           lintAnnots )
 import Simplify         ( simplTopBinds, simplExpr, simplRules )
-import SimplUtils       ( simplEnvForGHCi, activeRule )
+import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )
 import SimplEnv
 import SimplMonad
 import CoreMonad
@@ -34,7 +37,7 @@ import FloatOut         ( floatOutwards )
 import FamInstEnv
 import Id
 import ErrUtils         ( withTiming )
-import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
 import VarSet
 import VarEnv
 import LiberateCase     ( liberateCase )
@@ -43,26 +46,19 @@ import Specialise       ( specProgram)
 import SpecConstr       ( specConstrProgram)
 import DmdAnal          ( dmdAnalProgram )
 import CallArity        ( callArityAnalProgram )
+import Exitify          ( exitifyProgram )
 import WorkWrap         ( wwTopBinds )
-import Vectorise        ( vectorise )
 import SrcLoc
 import Util
 import Module
+import Plugins          ( withPlugins, installCoreToDos )
+import DynamicLoading  -- ( initializePlugins )
 
-import Maybes
 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import UniqFM
 import Outputable
 import Control.Monad
 import qualified GHC.LanguageExtensions as LangExt
-
-#if defined(GHCI)
-import DynamicLoading   ( loadPlugins )
-import Plugins          ( installCoreToDos )
-#else
-import DynamicLoading   ( pluginError )
-#endif
-
 {-
 ************************************************************************
 *                                                                      *
@@ -84,7 +80,12 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod
        ;
        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
                                     orph_mods print_unqual loc $
-                           do { all_passes <- addPluginPasses builtin_passes
+                           do { hsc_env' <- getHscEnv
+                              ; dflags' <- liftIO $ initializePlugins hsc_env'
+                                                      (hsc_dflags hsc_env')
+                              ; all_passes <- withPlugins dflags'
+                                                installCoreToDos
+                                                builtin_passes
                               ; runCorePasses all_passes guts }
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
@@ -120,6 +121,7 @@ getCoreToDo dflags
     max_iter      = maxSimplIterations dflags
     rule_check    = ruleCheck          dflags
     call_arity    = gopt Opt_CallArity                    dflags
+    exitification = gopt Opt_Exitification                dflags
     strictness    = gopt Opt_Strictness                   dflags
     full_laziness = gopt Opt_FullLaziness                 dflags
     do_specialise = gopt Opt_Specialise                   dflags
@@ -128,11 +130,11 @@ getCoreToDo dflags
     spec_constr   = gopt Opt_SpecConstr                   dflags
     liberate_case = gopt Opt_LiberateCase                 dflags
     late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
+    late_specialise = gopt Opt_LateSpecialise             dflags
     static_args   = gopt Opt_StaticArgumentTransformation dflags
     rules_on      = gopt Opt_EnableRewriteRules           dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
     ww_on         = gopt Opt_WorkerWrapper                dflags
-    vectorise_on  = gopt Opt_Vectorise                    dflags
     static_ptrs   = xopt LangExt.StaticPointers           dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
@@ -142,6 +144,7 @@ getCoreToDo dflags
 
     base_mode = SimplMode { sm_phase      = panic "base_mode"
                           , sm_names      = []
+                          , sm_dflags     = dflags
                           , sm_rules      = rules_on
                           , sm_eta_expand = eta_expand_on
                           , sm_inline     = True
@@ -156,30 +159,6 @@ getCoreToDo dflags
 
           , maybe_rule_check (Phase phase) ]
 
-          -- Vectorisation can introduce a fair few common sub expressions involving
-          --  DPH primitives. For example, see the Reverse test from dph-examples.
-          --  We need to eliminate these common sub expressions before their definitions
-          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings,
-          --  so we also run simpl_gently to inline them.
-      ++  (if vectorise_on && phase == 3
-            then [CoreCSE, simpl_gently]
-            else [])
-
-    vectorisation
-      = runWhen vectorise_on $
-          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
-
-                -- By default, we have 2 phases before phase 0.
-
-                -- Want to run with inline phase 2 after the specialiser to give
-                -- maximum chance for fusion to work before we inline build/augment
-                -- in phase 1.  This made a difference in 'ansi' where an
-                -- overloaded function wasn't inlined till too late.
-
-                -- Need phase 1 so that build/augment get
-                -- inlined.  I found that spectral/hartel/genfft lost some useful
-                -- strictness in the function sumcode' if augment is not inlined
-                -- before strictness analysis runs
     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
                                 | phase <- [phases, phases-1 .. 1] ]
 
@@ -189,7 +168,7 @@ getCoreToDo dflags
                        (base_mode { sm_phase = InitialPhase
                                   , sm_names = ["Gentle"]
                                   , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
-                                  , sm_inline = not vectorise_on
+                                  , sm_inline = True
                                               -- See Note [Inline in InitialPhase]
                                   , sm_case_case = False })
                           -- Don't do case-of-case transformations.
@@ -222,8 +201,7 @@ getCoreToDo dflags
 
     core_todo =
      if opt_level == 0 then
-       [ vectorisation,
-         static_ptrs_float_outwards,
+       [ static_ptrs_float_outwards,
          CoreDoSimplify max_iter
              (base_mode { sm_phase = Phase 0
                         , sm_names = ["Non-opt simplification"] })
@@ -237,10 +215,6 @@ getCoreToDo dflags
     -- after this before anything else
         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
 
-        -- We run vectorisation here for now, but we might also try to run
-        -- it later
-        vectorisation,
-
         -- initial simplify: mk specialiser happy: minimum effort please
         simpl_gently,
 
@@ -305,6 +279,9 @@ getCoreToDo dflags
 
         runWhen strictness demand_analyser,
 
+        runWhen exitification CoreDoExitify,
+            -- See note [Placement of the exitification pass]
+
         runWhen full_laziness $
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas     = floatLamArgs dflags,
@@ -340,6 +317,16 @@ getCoreToDo dflags
 
         maybe_rule_check (Phase 0),
 
+        runWhen late_specialise
+          (CoreDoPasses [ CoreDoSpecialising
+                        , simpl_phase 0 ["post-late-spec"] max_iter]),
+
+        -- LiberateCase can yield new CSE opportunities because it peels
+        -- off one layer of a recursive function (concretely, I saw this
+        -- in wheel-sieve1), and I'm guessing that SpecConstr can too
+        -- And CSE is a very cheap pass. So it seems worth doing here.
+        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,
+
         -- Final clean-up simplification:
         simpl_phase 0 ["final"] max_iter,
 
@@ -365,24 +352,6 @@ getCoreToDo dflags
       flatten_todos passes ++ flatten_todos rest
     flatten_todos (todo : rest) = todo : flatten_todos rest
 
--- Loading plugins
-
-addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
-#if !defined(GHCI)
-addPluginPasses builtin_passes
-  = do { dflags <- getDynFlags
-       ; let pluginMods = pluginModNames dflags
-       ; unless (null pluginMods) (pluginError pluginMods)
-       ; return builtin_passes }
-#else
-addPluginPasses builtin_passes
-  = do { hsc_env <- getHscEnv
-       ; named_plugins <- liftIO (loadPlugins hsc_env)
-       ; foldM query_plug builtin_passes named_plugins }
-  where
-    query_plug todos (_, plug, options) = installCoreToDos plug options todos
-#endif
-
 {- Note [Inline in InitialPhase]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
@@ -473,6 +442,9 @@ doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
 doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
                                        doPassD callArityAnalProgram
 
+doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}
+                                       doPass exitifyProgram
+
 doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                        doPassDFM dmdAnalProgram
 
@@ -485,9 +457,6 @@ doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                        specConstrProgram
 
-doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
-                                       vectorise
-
 doCorePass CoreDoPrintCore              = observe   printCore
 doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
 doCorePass CoreDoNothing                = return
@@ -495,9 +464,15 @@ doCorePass (CoreDoPasses passes)        = runCorePasses passes
 
 #if defined(GHCI)
 doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+#else
+doCorePass pass@CoreDoPluginPass {}  = pprPanic "doCorePass" (ppr pass)
 #endif
 
-doCorePass pass = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)
 
 {-
 ************************************************************************
@@ -519,10 +494,12 @@ ruleCheckPass current_phase pat guts =
     { rb <- getRuleBase
     ; dflags <- getDynFlags
     ; vis_orphs <- getVisibleOrphanMods
+    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
+                        ++ (mg_rules guts)
     ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
                    (defaultDumpStyle dflags)
                    (ruleCheckProgram current_phase pat
-                      (RuleEnv rb vis_orphs) (mg_binds guts))
+                      rule_fn (mg_binds guts))
     ; return guts }
 
 doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
@@ -619,7 +596,7 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 --      (b) the LHS and RHS of a RULE
 --      (c) Template Haskell splices
 --
--- The name 'Gently' suggests that the SimplifierMode is SimplGently,
+-- The name 'Gently' suggests that the SimplMode is SimplGently,
 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 -- enforce that; it just simplifies the expression twice
 
@@ -679,7 +656,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
     dflags       = hsc_dflags hsc_env
     print_unqual = mkPrintUnqualified dflags rdr_env
     simpl_env    = mkSimplEnv mode
-    active_rule  = activeRule simpl_env
+    active_rule  = activeRule mode
+    active_unf   = activeUnfolding mode
 
     do_iteration :: UniqSupply
                  -> Int          -- Counts iterations
@@ -711,30 +689,9 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
       , () <- sz `seq` ()     -- Force it
       = do {
                 -- Occurrence analysis
-           let {   -- Note [Vectorisation declarations and occurrences]
-                   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-                   -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
-                   -- that the right-hand sides of vectorisation declarations are taken into
-                   -- account during occurrence analysis. After the 'InitialPhase', we need to ensure
-                   -- that the binders representing variable vectorisation declarations are kept alive.
-                   -- (In contrast to automatically vectorised variables, their unvectorised versions
-                   -- don't depend on them.)
-                 vectVars = mkVarSet $
-                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
-                                        | Vect bndr _ <- mg_vect_decls guts]
-                              ++
-                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
-                                        | bndr <- bindersOfBinds binds]
-                                        -- FIXME: This second comprehensions is only needed as long as we
-                                        --        have vectorised bindings where we get "Could NOT call
-                                        --        vectorised from original version".
-              ;  (maybeVects, maybeVectVars)
-                   = case sm_phase mode of
-                       InitialPhase -> (mg_vect_decls guts, vectVars)
-                       _            -> ([], vectVars)
-               ; tagged_binds = {-# SCC "OccAnal" #-}
-                     occurAnalysePgm this_mod active_rule rules
-                                     maybeVects maybeVectVars binds
+           let { tagged_binds = {-# SCC "OccAnal" #-}
+                     occurAnalysePgm this_mod active_unf active_rule rules
+                                     binds
                } ;
            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                      (pprCoreBindings tagged_binds);
@@ -754,18 +711,19 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
                 -- Simplify the program
            ((binds1, rules1), counts1) <-
              initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
-               do { env1 <- {-# SCC "SimplTopBinds" #-}
-                            simplTopBinds simpl_env tagged_binds
+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
+                                      simplTopBinds simpl_env tagged_binds
 
                       -- Apply the substitution to rules defined in this module
                       -- for imported Ids.  Eg  RULE map my_f = blah
                       -- If we have a substitution my_f :-> other_f, we'd better
                       -- apply it to the rule to, or it'll never match
-                  ; rules1 <- simplRules env1 Nothing rules
+                  ; rules1 <- simplRules env1 Nothing rules Nothing
 
-                  ; return (getFloatBinds env1, rules1) } ;
+                  ; return (getTopFloatBinds floats, rules1) } ;
 
                 -- Stop if nothing happened; don't dump output
+                -- See Note [Which transformations are innocuous] in CoreMonad
            if isZeroSimplCount counts1 then
                 return ( "Simplifier reached fixed point", iteration_no
                        , totalise (counts1 : counts_so_far)  -- Include "free" ticks
@@ -838,16 +796,6 @@ save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 makes strictness information propagate better.  This used to happen in
 the final phase, but it's tidier to do it here.
 
-Note [Transferring IdInfo]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to propagage any useful IdInfo on x_local to x_exported.
-
-STRICTNESS: if we have done strictness analysis, we want the strictness info on
-x_local to transfer to x_exported.  Hence the copyIdInfo call.
-
-RULES: we want to *add* any RULES for x_local to x_exported.
-
-
 Note [Messing up the exported Id's RULES]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must be careful about discarding (obviously) or even merging the
@@ -941,7 +889,6 @@ unfolding for something.
 
 Note [Indirection zapping and ticks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Unfortunately this is another place where we need a special case for
 ticks. The following happens quite regularly:
 
@@ -981,12 +928,18 @@ shortOutIndirections binds
     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
 
     zapPair (bndr, rhs)
-        | bndr `elemVarSet` exp_id_set = []
+        | bndr `elemVarSet` exp_id_set
+        = []   -- Kill the exported-id binding
+
         | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
-                                       = [(transferIdInfo exp_id bndr,
-                                           mkTicks ticks rhs),
-                                          (bndr, Var exp_id)]
-        | otherwise                    = [(bndr,rhs)]
+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr
+        =      -- Turn a local-id binding into two bindings
+               --    exp_id = rhs; lcl_id = exp_id
+          [ (exp_id', mkTicks ticks rhs),
+            (lcl_id', Var exp_id') ]
+
+        | otherwise
+        = [(bndr,rhs)]
 
 makeIndEnv :: [CoreBind] -> IndEnv
 makeIndEnv binds
@@ -1039,16 +992,32 @@ hasShortableIdInfo id
      info = idInfo id
 
 -----------------
-transferIdInfo :: Id -> Id -> Id
+{- Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+     lcl_id = e; exp_id = lcl_id
+
+and lcl_id has useful IdInfo, we don't want to discard it by going
+     gbl_id = e; lcl_id = gbl_id
+
+Instead, transfer IdInfo from lcl_id to exp_id, specifically
+* (Stable) unfolding
+* Strictness
+* Rules
+* Inline pragma
+
+Overwriting, rather than merging, seems to work ok.
+
+We also zap the InlinePragma on the lcl_id. It might originally
+have had a NOINLINE, which we have now transferred; and we really
+want the lcl_id to inline now that its RHS is trivial!
+-}
+
+transferIdInfo :: Id -> Id -> (Id, Id)
 -- See Note [Transferring IdInfo]
--- If we have
---      lcl_id = e; exp_id = lcl_id
--- and lcl_id has useful IdInfo, we don't want to discard it by going
---      gbl_id = e; lcl_id = gbl_id
--- Instead, transfer IdInfo from lcl_id to exp_id
--- Overwriting, rather than merging, seems to work ok.
 transferIdInfo exported_id local_id
-  = modifyIdInfo transfer exported_id
+  = ( modifyIdInfo transfer exported_id
+    , local_id `setInlinePragma` defaultInlinePragma )
   where
     local_info = idInfo local_id
     transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
index 9316ec08af..1d55f359fa 100644
--- a/compiler/simplCore/SimplEnv.hs
+++ b/compiler/simplCore/SimplEnv.hs
@@ -8,14 +8,14 @@
 
 module SimplEnv (
         -- * The simplifier mode
-        setMode, getMode, updMode,
+        setMode, getMode, updMode, seDynFlags,
 
         -- * Environments
-        SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract
+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract
         mkSimplEnv, extendIdSubst,
         SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
         zapSubstEnv, setSubstEnv,
-        getInScope, setInScopeAndZapFloats,
+        getInScope, setInScopeFromE, setInScopeFromF,
         setInScopeSet, modifyInScope, addNewInScopeIds,
         getSimplRules,
 
@@ -29,19 +29,26 @@ module SimplEnv (
         substCo, substCoVar,
 
         -- * Floats
-        Floats, emptyFloats, isEmptyFloats,
-        addNonRec, addLetFloats, addFloats, extendFloats, addFlts,
-        wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
-        doFloatFromRhs, getFloatBinds,
-
-        JoinFloat, JoinFloats, emptyJoinFloats, isEmptyJoinFloats,
-        wrapJoinFloats, wrapJoinFloatsX, zapJoinFloats, addJoinFloats
+        SimplFloats(..), emptyFloats, mkRecFloats,
+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,
+        extendFloats, wrapFloats,
+        doFloatFromRhs, getTopFloatBinds,
+
+        -- * LetFloats
+        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
+        addLetFlts,  mapLetFloats,
+
+        -- * JoinFloats
+        JoinFloat, JoinFloats, emptyJoinFloats,
+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import SimplMonad
-import CoreMonad                ( SimplifierMode(..) )
+import CoreMonad                ( SimplMode(..) )
 import CoreSyn
 import CoreUtils
 import Var
@@ -50,6 +57,7 @@ import VarSet
 import OrdList
 import Id
 import MkCore                   ( mkWildValBinder )
+import DynFlags                 ( DynFlags )
 import TysWiredIn
 import qualified Type
 import Type hiding              ( substTy, substTyVar, substTyVarBndr )
@@ -77,12 +85,12 @@ data SimplEnv
      -- Static in the sense of lexically scoped,
      -- wrt the original expression
 
-        seMode      :: SimplifierMode,
+        seMode      :: SimplMode
 
         -- The current substitution
-        seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
-        seCvSubst   :: CvSubstEnv,      -- InCoVar |--> OutCoercion
-        seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr
+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType
+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion
+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr
 
      ----------- Dynamic part of the environment -----------
      -- Dynamic in the sense of describing the setup where
@@ -90,23 +98,40 @@ data SimplEnv
 
         -- The current set of in-scope variables
         -- They are all OutVars, and all bound in this module
-        seInScope   :: InScopeSet,      -- OutVars only
-                -- Includes all variables bound
-                -- by seLetFloats and seJoinFloats
+      , seInScope   :: InScopeSet       -- OutVars only
+    }
 
-        -- Ordinary bindings
-        seLetFloats  :: Floats,
-                -- See Note [Simplifier floats]
+data SimplFloats
+  = SimplFloats
+      { -- Ordinary let bindings
+        sfLetFloats  :: LetFloats
+                -- See Note [LetFloats]
 
         -- Join points
-        seJoinFloats :: JoinFloats
+      , sfJoinFloats :: JoinFloats
                 -- Handled separately; they don't go very far
-                -- We consider these to be /inside/ seLetFloats
+                -- We consider these to be /inside/ sfLetFloats
                 -- because join points can refer to ordinary bindings,
                 -- but not vice versa
-    }
 
-type StaticEnv = SimplEnv       -- Just the static part is relevant
+        -- Includes all variables bound by sfLetFloats and
+        -- sfJoinFloats, plus at least whatever is in scope where
+        -- these bindings land up.
+      , sfInScope :: InScopeSet  -- All OutVars
+      }
+
+instance Outputable SimplFloats where
+  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
+    = text "SimplFloats"
+      <+> braces (vcat [ text "lets: " <+> ppr lf
+                       , text "joins:" <+> ppr jf
+                       , text "in_scope:" <+> ppr is ])
+
+emptyFloats :: SimplEnv -> SimplFloats
+emptyFloats env
+  = SimplFloats { sfLetFloats  = emptyLetFloats
+                , sfJoinFloats = emptyJoinFloats
+                , sfInScope    = seInScope env }
 
 pprSimplEnv :: SimplEnv -> SDoc
 -- Used for debugging; selective
@@ -241,12 +266,10 @@ need to know at the occurrence site that the variable is a join point
 so that we know to drop the context. Thus we remember which join
 points we're substituting. -}
 
-mkSimplEnv :: SimplifierMode -> SimplEnv
+mkSimplEnv :: SimplMode -> SimplEnv
 mkSimplEnv mode
   = SimplEnv { seMode = mode
              , seInScope = init_in_scope
-             , seLetFloats = emptyFloats
-             , seJoinFloats = emptyJoinFloats
              , seTvSubst = emptyVarEnv
              , seCvSubst = emptyVarEnv
              , seIdSubst = emptyVarEnv }
@@ -276,13 +299,16 @@ wild-ids before doing much else.
 It's a very dark corner of GHC.  Maybe it should be cleaned up.
 -}
 
-getMode :: SimplEnv -> SimplifierMode
+getMode :: SimplEnv -> SimplMode
 getMode env = seMode env
 
-setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+seDynFlags :: SimplEnv -> DynFlags
+seDynFlags env = sm_dflags (seMode env)
+
+setMode :: SimplMode -> SimplEnv -> SimplEnv
 setMode mode env = env { seMode = mode }
 
-updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
+updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
 updMode upd env = env { seMode = upd (seMode env) }
 
 ---------------------
@@ -293,7 +319,7 @@ extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 
 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
-  = ASSERT( isTyVar var )
+  = ASSERT2( isTyVar var, ppr var $$ ppr res )
     env {seTvSubst = extendVarEnv tsubst var res}
 
 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
@@ -308,19 +334,12 @@ getInScope env = seInScope env
 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 setInScopeSet env in_scope = env {seInScope = in_scope}
 
-setInScopeAndZapFloats :: SimplEnv -> SimplEnv -> SimplEnv
--- Set the in-scope set, and *zap* the floats
-setInScopeAndZapFloats env env_with_scope
-  = env { seInScope    = seInScope env_with_scope,
-          seLetFloats  = emptyFloats,
-          seJoinFloats = emptyJoinFloats }
+setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
+-- See Note [Setting the right in-scope set]
+setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }
 
-setFloats :: SimplEnv -> SimplEnv -> SimplEnv
--- Set the in-scope set *and* the floats
-setFloats env env_with_floats
-  = env { seInScope    = seInScope env_with_floats,
-          seLetFloats  = seLetFloats  env_with_floats,
-          seJoinFloats = seJoinFloats env_with_floats }
+setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
+setInScopeFromF env floats = env { seInScope = sfInScope floats }
 
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
         -- The new Ids are guaranteed to be freshly allocated
@@ -340,6 +359,30 @@ modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
   = env {seInScope = extendInScopeSet in_scope v}
 
+{- Note [Setting the right in-scope set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  \x. (let x = e in b) arg[x]
+where the let shadows the lambda.  Really this means something like
+  \x1. (let x2 = e in b) arg[x1]
+
+- When we capture the 'arg' in an ApplyToVal continuation, we capture
+  the environment, which says what 'x' is bound to, namely x1
+
+- Then that continuation gets pushed under the let
+
+- Finally we simplify 'arg'.  We want
+     - the static, lexical environment bindig x :-> x1
+     - the in-scopeset from "here", under the 'let' which includes
+       both x1 and x2
+
+It's important to have the right in-scope set, else we may rename a
+variable to one that is already in scope.  So we must pick up the
+in-scope set from "here", but otherwise use the environment we
+captured along with 'arg'.  This transfer of in-scope set is done by
+setInScopeFromE.
+-}
+
 ---------------------
 zapSubstEnv :: SimplEnv -> SimplEnv
 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
@@ -353,13 +396,13 @@ mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = Co
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Floats}
+\subsection{LetFloats}
 *                                                                      *
 ************************************************************************
 
-Note [Simplifier floats]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-The Floats is a bunch of bindings, classified by a FloatFlag.
+Note [LetFloats]
+~~~~~~~~~~~~~~~~
+The LetFloats is a bunch of bindings, classified by a FloatFlag.
 
 * All of them satisfy the let/app invariant
 
@@ -378,8 +421,8 @@ Can't happen:
   NonRec x# (f y)       -- Might diverge; does not satisfy let/app
 -}
 
-data Floats = Floats (OrdList OutBind) FloatFlag
-        -- See Note [Simplifier floats]
+data LetFloats = LetFloats (OrdList OutBind) FloatFlag
+                 -- See Note [LetFloats]
 
 type JoinFloat  = OutBind
 type JoinFloats = OrdList JoinFloat
@@ -401,12 +444,12 @@ data FloatFlag
                 --      and not guaranteed cheap
                 --      Do not float these bindings out of a lazy let
 
-instance Outputable Floats where
-  ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
+instance Outputable LetFloats where
+  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)
 
 instance Outputable FloatFlag where
-  ppr FltLifted = text "FltLifted"
-  ppr FltOkSpec = text "FltOkSpec"
+  ppr FltLifted  = text "FltLifted"
+  ppr FltOkSpec  = text "FltOkSpec"
   ppr FltCareful = text "FltCareful"
 
 andFF :: FloatFlag -> FloatFlag -> FloatFlag
@@ -415,9 +458,9 @@ andFF FltOkSpec  FltCareful = FltCareful
 andFF FltOkSpec  _          = FltOkSpec
 andFF FltLifted  flt        = flt
 
-doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
 -- If you change this function look also at FloatIn.noFloatFromRhs
-doFloatFromRhs lvl rec str rhs (SimplEnv {seLetFloats = Floats fs ff})
+doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
   =  not (isNilOL fs) && want_to_float && can_float
   where
      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
@@ -439,23 +482,23 @@ But there are
 so we must take the 'or' of the two.
 -}
 
-emptyFloats :: Floats
-emptyFloats = Floats nilOL FltLifted
+emptyLetFloats :: LetFloats
+emptyLetFloats = LetFloats nilOL FltLifted
 
 emptyJoinFloats :: JoinFloats
 emptyJoinFloats = nilOL
 
-unitFloat :: OutBind -> Floats
+unitLetFloat :: OutBind -> LetFloats
 -- This key function constructs a singleton float with the right form
-unitFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
-                 Floats (unitOL bind) (flag bind)
+unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
+                    LetFloats (unitOL bind) (flag bind)
   where
     flag (Rec {})                = FltLifted
     flag (NonRec bndr rhs)
       | not (isStrictId bndr)    = FltLifted
-      | exprIsLiteralString rhs  = FltLifted
+      | exprIsTickedString rhs   = FltLifted
           -- String literals can be floated freely.
-          -- See Note [CoreSyn top-level string ltierals] in CoreSyn.
+          -- See Note [CoreSyn top-level string literals] in CoreSyn.
       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
       | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
                                    FltCareful
@@ -465,138 +508,132 @@ unitJoinFloat :: OutBind -> JoinFloats
 unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
                      unitOL bind
 
-addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
--- Add a non-recursive binding and extend the in-scope set
--- The latter is important; the binder may already be in the
--- in-scope set (although it might also have been created with newId)
--- but it may now have more IdInfo
-addNonRec env@(SimplEnv { seLetFloats  = floats
-                        , seJoinFloats = jfloats
-                        , seInScope = in_scope })
-          id rhs
-  | isJoinId id  -- This test incidentally forces the Id, and hence
-                 -- its IdInfo, and hence any inner substitutions
-  = env { seInScope    = in_scope'
-        , seLetFloats  = floats
-        , seJoinFloats = jfloats' }
-  | otherwise
-  = env { seInScope    = in_scope'
-        , seLetFloats  = floats'
-        , seJoinFloats = jfloats }
+mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
+-- Make a singleton SimplFloats, and
+-- extend the incoming SimplEnv's in-scope set with its binders
+-- These binders may already be in the in-scope set,
+-- but may have by now been augmented with more IdInfo
+mkFloatBind env bind
+  = (floats, env { seInScope = in_scope' })
   where
-    bind      = NonRec id rhs
-    in_scope' = extendInScopeSet in_scope id
-    floats'   = floats  `addFlts`     unitFloat     bind
-    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
-
-extendFloats :: SimplEnv -> OutBind -> SimplEnv
+    floats
+      | isJoinBind bind
+      = SimplFloats { sfLetFloats  = emptyLetFloats
+                    , sfJoinFloats = unitJoinFloat bind
+                    , sfInScope    = in_scope' }
+      | otherwise
+      = SimplFloats { sfLetFloats  = unitLetFloat bind
+                    , sfJoinFloats = emptyJoinFloats
+                    , sfInScope    = in_scope' }
+
+    in_scope' = seInScope env `extendInScopeSetBind` bind
+
+extendFloats :: SimplFloats -> OutBind -> SimplFloats
 -- Add this binding to the floats, and extend the in-scope env too
-extendFloats env@(SimplEnv { seLetFloats  = floats
-                           , seJoinFloats = jfloats
-                           , seInScope = in_scope })
+extendFloats (SimplFloats { sfLetFloats  = floats
+                          , sfJoinFloats = jfloats
+                          , sfInScope    = in_scope })
              bind
   | isJoinBind bind
-  = env { seInScope    = in_scope'
-        , seLetFloats  = floats
-        , seJoinFloats = jfloats' }
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats
+                , sfJoinFloats = jfloats' }
   | otherwise
-  = env { seInScope    = in_scope'
-        , seLetFloats  = floats'
-        , seJoinFloats = jfloats }
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats'
+                , sfJoinFloats = jfloats }
   where
-    bndrs = bindersOf bind
-
-    in_scope' = extendInScopeSetList in_scope bndrs
-    floats'   = floats  `addFlts`     unitFloat bind
+    in_scope' = in_scope `extendInScopeSetBind` bind
+    floats'   = floats  `addLetFlts`  unitLetFloat bind
     jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
 
-addLetFloats :: SimplEnv -> SimplEnv -> SimplEnv
+addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
 -- Add the let-floats for env2 to env1;
 -- *plus* the in-scope set for env2, which is bigger
 -- than that for env1
-addLetFloats env1 env2
-  = env1 { seLetFloats = seLetFloats env1 `addFlts` seLetFloats env2
-         , seInScope   = seInScope env2 }
-
-addFloats :: SimplEnv -> SimplEnv -> SimplEnv
+addLetFloats floats let_floats@(LetFloats binds _)
+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
+           , sfInScope   = foldlOL extendInScopeSetBind
+                                   (sfInScope floats) binds }
+
+addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
+addJoinFloats floats join_floats
+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats
+           , sfInScope    = foldlOL extendInScopeSetBind
+                                    (sfInScope floats) join_floats }
+
+extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
+extendInScopeSetBind in_scope bind
+  = extendInScopeSetList in_scope (bindersOf bind)
+
+addFloats :: SimplFloats -> SimplFloats -> SimplFloats
 -- Add both let-floats and join-floats for env2 to env1;
 -- *plus* the in-scope set for env2, which is bigger
 -- than that for env1
-addFloats env1 env2
-  = env1 { seLetFloats  = seLetFloats env1 `addFlts` seLetFloats env2
-         , seJoinFloats = seJoinFloats env1 `addJoinFlts` seJoinFloats env2
-         , seInScope    = seInScope env2 }
+addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
+          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })
+  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2
+                , sfJoinFloats = jf1 `addJoinFlts` jf2
+                , sfInScope    = in_scope }
 
-addFlts :: Floats -> Floats -> Floats
-addFlts (Floats bs1 l1) (Floats bs2 l2)
-  = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
+addLetFlts :: LetFloats -> LetFloats -> LetFloats
+addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
+  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+letFloatBinds :: LetFloats -> [CoreBind]
+letFloatBinds (LetFloats bs _) = fromOL bs
 
 addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
 addJoinFlts = appOL
 
-zapFloats :: SimplEnv -> SimplEnv
-zapFloats env = env { seLetFloats  = emptyFloats
-                    , seJoinFloats = emptyJoinFloats }
-
-zapJoinFloats :: SimplEnv -> SimplEnv
-zapJoinFloats env = env { seJoinFloats = emptyJoinFloats }
-
-addJoinFloats :: SimplEnv -> JoinFloats -> SimplEnv
-addJoinFloats env@(SimplEnv { seJoinFloats = fb1 }) fb2
-  = env { seJoinFloats = fb1 `addJoinFlts` fb2 }
-
-addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
+mkRecFloats :: SimplFloats -> SimplFloats
 -- Flattens the floats from env2 into a single Rec group,
--- prepends the floats from env1, and puts the result back in env2
--- This is all very specific to the way recursive bindings are
--- handled; see Simplify.simplRecBind
-addRecFloats env1 env2@(SimplEnv {seLetFloats  = Floats bs ff
-                                 ,seJoinFloats = jbs })
+-- They must either all be lifted LetFloats or all JoinFloats
+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff
+                                , sfJoinFloats = jbs
+                                , sfInScope    = in_scope })
   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
-    env2 {seLetFloats = seLetFloats env1 `addFlts` floats'
-         ,seJoinFloats = seJoinFloats env1 `addJoinFlts` jfloats'}
+    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
+    SimplFloats { sfLetFloats  = floats'
+                , sfJoinFloats = jfloats'
+                , sfInScope    = in_scope }
   where
-    floats'  | isNilOL bs  = emptyFloats
-             | otherwise   = unitFloat (Rec (flattenBinds (fromOL bs)))
+    floats'  | isNilOL bs  = emptyLetFloats
+             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))
     jfloats' | isNilOL jbs = emptyJoinFloats
              | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
 
-wrapFloats :: SimplEnv -> OutExpr -> OutExpr
+wrapFloats :: SimplFloats -> OutExpr -> OutExpr
 -- Wrap the floats around the expression; they should all
 -- satisfy the let/app invariant, so mkLets should do the job just fine
-wrapFloats (SimplEnv { seLetFloats  = Floats bs _
-                     , seJoinFloats = jbs }) body
+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _
+                        , sfJoinFloats = jbs }) body
   = foldrOL Let (wrapJoinFloats jbs body) bs
      -- Note: Always safe to put the joins on the inside
      -- since the values can't refer to them
 
-wrapJoinFloatsX :: SimplEnv -> OutExpr -> (SimplEnv, OutExpr)
--- Wrap the seJoinFloats of the env around the expression,
+wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
+-- Wrap the sfJoinFloats of the env around the expression,
 -- and take them out of the SimplEnv
-wrapJoinFloatsX env@(SimplEnv { seJoinFloats = jbs }) body
-  = (zapJoinFloats env, wrapJoinFloats jbs body)
+wrapJoinFloatsX floats body
+  = ( floats { sfJoinFloats = emptyJoinFloats }
+    , wrapJoinFloats (sfJoinFloats floats) body )
 
 wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
--- Wrap the seJoinFloats of the env around the expression,
+-- Wrap the sfJoinFloats of the env around the expression,
 -- and take them out of the SimplEnv
 wrapJoinFloats join_floats body
   = foldrOL Let body join_floats
 
-getFloatBinds :: SimplEnv -> [CoreBind]
-getFloatBinds (SimplEnv {seLetFloats = Floats bs _, seJoinFloats = jbs})
-  = fromOL bs ++ fromOL jbs
-
-isEmptyFloats :: SimplEnv -> Bool
-isEmptyFloats env@(SimplEnv {seLetFloats = Floats bs _})
-  = isNilOL bs && isEmptyJoinFloats env
-
-isEmptyJoinFloats :: SimplEnv -> Bool
-isEmptyJoinFloats (SimplEnv {seJoinFloats = jbs})
-  = isNilOL jbs
+getTopFloatBinds :: SimplFloats -> [CoreBind]
+getTopFloatBinds (SimplFloats { sfLetFloats  = lbs
+                              , sfJoinFloats = jbs})
+  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
+    letFloatBinds lbs
 
-mapFloats :: Floats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> Floats
-mapFloats (Floats fs ff) fun
-   = Floats (mapOL app fs) ff
+mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
+mapLetFloats (LetFloats fs ff) fun
+   = LetFloats (mapOL app fs) ff
    where
     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
     app (Rec bs)     = Rec (map fun bs)
@@ -657,6 +694,34 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 
 
 These functions are in the monad only so that they can be made strict via seq.
+
+Note [Return type for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   (join j :: Char -> Int -> Int) 77
+   (     j x = \y. y + ord x    )
+   (in case v of                )
+   (     A -> j 'x'             )
+   (     B -> j 'y'             )
+   (     C -> <blah>            )
+
+The simplifier pushes the "apply to 77" continuation inwards to give
+
+   join j :: Char -> Int
+        j x = (\y. y + ord x) 77
+   in case v of
+        A -> j 'x'
+        B -> j 'y'
+        C -> <blah> 77
+
+Notice that the "apply to 77" continuation went into the RHS of the
+join point.  And that meant that the return type of the join point
+changed!!
+
+That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr
+takes a (Just res_ty) argument so that it knows to do the type-changing
+thing.
 -}
 
 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
@@ -685,8 +750,9 @@ simplNonRecBndr env id
 ---------------
 simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr
                     -> SimplM (SimplEnv, OutBndr)
--- A non-recursive let binder for a join point; context being pushed inward may
--- change the type
+-- A non-recursive let binder for a join point;
+-- context being pushed inward may change the type
+-- See Note [Return type for join points]
 simplNonRecJoinBndr env res_ty id
   = do  { let (env1, id1) = substIdBndr (Just res_ty) env id
         ; seqId id1 `seq` return (env1, id1) }
@@ -701,8 +767,9 @@ simplRecBndrs env@(SimplEnv {}) ids
 
 ---------------
 simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv
--- Recursive let binders for join points; context being pushed inward may
--- change types
+-- Recursive let binders for join points;
+-- context being pushed inward may change types
+-- See Note [Return type for join points]
 simplRecJoinBndrs env@(SimplEnv {}) res_ty ids
   = ASSERT(all isJoinId ids)
     do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids
@@ -718,6 +785,7 @@ substIdBndr new_res_ty env bndr
 ---------------
 substNonCoVarIdBndr
    :: Maybe OutType -- New result type, if a join binder
+                    -- See Note [Return type for join points]
    -> SimplEnv
    -> InBndr    -- Env and binder to transform
    -> (SimplEnv, OutBndr)
@@ -748,10 +816,13 @@ substNonCoVarIdBndr new_res_ty
   where
     id1    = uniqAway in_scope old_id
     id2    = substIdType env id1
+
     id3    | Just res_ty <- new_res_ty
            = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)
+                             -- See Note [Return type for join points]
            | otherwise
            = id2
+
     new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding
                                         -- and fragile OccInfo
 
diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
index 015ee5c786..915c89ee91 100644
--- a/compiler/simplCore/SimplMonad.hs
+++ b/compiler/simplCore/SimplMonad.hs
@@ -19,6 +19,8 @@ module SimplMonad (
         plusSimplCount, isZeroSimplCount
     ) where
 
+import GhcPrelude
+
 import Var              ( Var, isTyVar, mkLocalVar )
 import Name             ( mkSystemVarName )
 import Id               ( Id, mkSysLocalOrCoVar )
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index e6e660b91f..ca1b9bd23d 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -17,8 +17,8 @@ module SimplUtils (
         simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
 
         -- The continuation type
-        SimplCont(..), DupFlag(..),
-        isSimplified,
+        SimplCont(..), DupFlag(..), StaticEnv,
+        isSimplified, contIsStop,
         contIsDupable, contResultType, contHoleType,
         contIsTrivial, contArgs,
         countArgs,
@@ -30,13 +30,18 @@ module SimplUtils (
         addValArgTo, addCastTo, addTyArgTo,
         argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
 
-        abstractFloats
+        abstractFloats,
+
+        -- Utilities
+        isExitJoinId
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import SimplEnv
-import CoreMonad        ( SimplifierMode(..), Tick(..) )
+import CoreMonad        ( SimplMode(..), Tick(..) )
 import DynFlags
 import CoreSyn
 import qualified CoreSubst
@@ -57,6 +62,7 @@ import DataCon          ( dataConWorkId, isNullaryRepDataCon )
 import VarSet
 import BasicTypes
 import Util
+import OrdList          ( isNilOL )
 import MonadUtils
 import Outputable
 import Pair
@@ -114,7 +120,7 @@ data SimplCont
   | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
       { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]
       , sc_arg  :: InExpr       -- The argument,
-      , sc_env  :: StaticEnv    --     and its static env
+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
       , sc_cont :: SimplCont }
 
   | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]
@@ -127,7 +133,7 @@ data SimplCont
       { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]
       , sc_bndr :: InId           -- case binder
       , sc_alts :: [InAlt]        -- Alternatives
-      , sc_env  :: StaticEnv      --   and their static environment
+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]
       , sc_cont :: SimplCont }
 
   -- The two strict forms have no DupFlag, because we never duplicate them
@@ -137,7 +143,7 @@ data SimplCont
       , sc_bndr  :: InId
       , sc_bndrs :: [InBndr]
       , sc_body  :: InExpr
-      , sc_env   :: StaticEnv
+      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]
       , sc_cont  :: SimplCont }
 
   | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]
@@ -151,6 +157,8 @@ data SimplCont
         (Tickish Id)    -- Tick tickish <hole>
         SimplCont
 
+type StaticEnv = SimplEnv       -- Just the static part is relevant
+
 data DupFlag = NoDup       -- Unsimplified, might be big
              | Simplified  -- Simplified
              | OkToDup     -- Simplified and small
@@ -164,7 +172,25 @@ perhapsSubstTy dup env ty
   | isSimplified dup = ty
   | otherwise        = substTy env ty
 
-{-
+{- Note [StaticEnv invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pair up an InExpr or InAlts with a StaticEnv, which establishes the
+lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we
+use
+  - Its captured StaticEnv
+  - Overriding its InScopeSet with the larger one at the
+    simplification point.
+
+Why override the InScopeSet?  Example:
+      (let y = ey in f) ex
+By the time we simplify ex, 'y' will be in scope.
+
+However the InScopeSet in the StaticEnv is not irrelevant: it should
+include all the free vars of applying the substitution to the InExpr.
+Reason: contHoleType uses perhapsSubstTy to apply the substitution to
+the expression, and that (rightly) gives ASSERT failures if the InScopeSet
+isn't big enough.
+
 Note [DupFlag invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 In both (ApplyToVal dup _ env k)
@@ -196,7 +222,7 @@ instance Outputable SimplCont where
     = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
   ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
     = (text "Select" <+> ppr dup <+> ppr bndr) $$
-       ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
+       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
 
 
 {- Note [The hole type in ApplyToTy]
@@ -345,6 +371,10 @@ contIsRhs (Stop _ RhsCtxt) = True
 contIsRhs _                = False
 
 -------------------
+contIsStop :: SimplCont -> Bool
+contIsStop (Stop {}) = True
+contIsStop _         = False
+
 contIsDupable :: SimplCont -> Bool
 contIsDupable (Stop {})                         = True
 contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
@@ -419,23 +449,25 @@ contArgs cont
 
 
 -------------------
-mkArgInfo :: Id
+mkArgInfo :: SimplEnv
+          -> Id
           -> [CoreRule] -- Rules for function
           -> Int        -- Number of value args
           -> SimplCont  -- Context of the call
           -> ArgInfo
 
-mkArgInfo fun rules n_val_args call_cont
+mkArgInfo env fun rules n_val_args call_cont
   | n_val_args < idArity fun            -- Note [Unsaturated functions]
   = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
-            , ai_rules = fun_rules, ai_encl = False
+            , ai_rules = fun_rules
+            , ai_encl = False
             , ai_strs = vanilla_stricts
             , ai_discs = vanilla_discounts }
   | otherwise
   = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
             , ai_rules = fun_rules
-            , ai_encl = interestingArgContext rules call_cont
-            , ai_strs  = add_type_str fun_ty arg_stricts
+            , ai_encl  = interestingArgContext rules call_cont
+            , ai_strs  = arg_stricts
             , ai_discs = arg_discounts }
   where
     fun_ty = idType fun
@@ -453,7 +485,11 @@ mkArgInfo fun rules n_val_args call_cont
     vanilla_stricts  = repeat False
 
     arg_stricts
-      = case splitStrictSig (idStrictness fun) of
+      | not (sm_inline (seMode env))
+      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]
+      | otherwise
+      = add_type_str fun_ty $
+        case splitStrictSig (idStrictness fun) of
           (demands, result_info)
                 | not (demands `lengthExceeds` n_val_args)
                 ->      -- Enough args, use the strictness given.
@@ -475,26 +511,25 @@ mkArgInfo fun rules n_val_args call_cont
     add_type_str :: Type -> [Bool] -> [Bool]
     -- If the function arg types are strict, record that in the 'strictness bits'
     -- No need to instantiate because unboxed types (which dominate the strict
-    -- types) can't instantiate type variables.
-    -- add_type_str is done repeatedly (for each call); might be better
-    -- once-for-all in the function
+    --   types) can't instantiate type variables.
+    -- add_type_str is done repeatedly (for each call);
+    --   might be better once-for-all in the function
     -- But beware primops/datacons with no strictness
 
-    add_type_str
-      = go
-      where
-        go _ [] = []
-        go fun_ty strs            -- Look through foralls
-            | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty       -- Includes coercions
-            = go fun_ty' strs
-        go fun_ty (str:strs)      -- Add strict-type info
-            | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
-            = (str || Just False == isLiftedType_maybe arg_ty) : go fun_ty' strs
-               -- If the type is levity-polymorphic, we can't know whether it's
-               -- strict. isLiftedType_maybe will return Just False only when
-               -- we're sure the type is unlifted.
-        go _ strs
-            = strs
+    add_type_str _ [] = []
+    add_type_str fun_ty all_strs@(str:strs)
+      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info
+      = (str || Just False == isLiftedType_maybe arg_ty)
+        : add_type_str fun_ty' strs
+          -- If the type is levity-polymorphic, we can't know whether it's
+          -- strict. isLiftedType_maybe will return Just False only when
+          -- we're sure the type is unlifted.
+
+      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
+      = add_type_str fun_ty' all_strs     -- Look through foralls
+
+      | otherwise
+      = all_strs
 
 {- Note [Unsaturated functions]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -504,6 +539,28 @@ Consider (test eyeball/inline4)
 where f has arity 2.  Then we do not want to inline 'x', because
 it'll just be floated out again.  Even if f has lots of discounts
 on its first argument -- it must be saturated for these to kick in
+
+Note [Do not expose strictness if sm_inline=False]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #15163 showed a case in which we had
+
+  {-# INLINE [1] zip #-}
+  zip = undefined
+
+  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}
+
+If we expose zip's bottoming nature when simplifing the LHS of the
+RULE we get
+  {-# RULES "foo" forall as bs.
+                   stream (case zip of {}) = ..blah... #-}
+discarding the arguments to zip.  Usually this is fine, but on the
+LHS of a rule it's not, because 'as' and 'bs' are now not bound on
+the LHS.
+
+This is a pretty pathalogical example, so I'm not losing sleep over
+it, but the simplest solution was to check sm_inline; if it is False,
+which it is on the LHS of a rule (see updModeForRules), then don't
+make use of the strictness info for the function.
 -}
 
 
@@ -546,14 +603,31 @@ since we can just eliminate this case instead (x is in WHNF).  Similar
 applies when x is bound to a lambda expression.  Hence
 contIsInteresting looks for case expressions with just a single
 default case.
+
+Note [No case of case is boring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+   case f x of <alts>
+
+we'd usually treat the context as interesting, to encourage 'f' to
+inline.  But if case-of-case is off, it's really not so interesting
+after all, because we are unlikely to be able to push the case
+expression into the branches of any case in f's unfolding.  So, to
+reduce unnecessary code expansion, we just make the context look boring.
+This made a small compile-time perf improvement in perf/compiler/T6048,
+and it looks plausible to me.
 -}
 
-interestingCallContext :: SimplCont -> CallCtxt
+interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
 -- See Note [Interesting call context]
-interestingCallContext cont
+interestingCallContext env cont
   = interesting cont
   where
-    interesting (Select {})     = CaseCtxt
+    interesting (Select {})
+       | sm_case_case (getMode env) = CaseCtxt
+       | otherwise                  = BoringCtxt
+       -- See Note [No case of case is boring]
+
     interesting (ApplyToVal {}) = ValAppCtxt
         -- Can happen if we have (f Int |> co) y
         -- If f has an INLINE prag we need to give it some
@@ -694,11 +768,11 @@ interestingArg env e = go env 0 e
 {-
 ************************************************************************
 *                                                                      *
-                  SimplifierMode
+                  SimplMode
 *                                                                      *
 ************************************************************************
 
-The SimplifierMode controls several switches; see its definition in
+The SimplMode controls several switches; see its definition in
 CoreMonad
         sm_rules      :: Bool     -- Whether RULES are enabled
         sm_inline     :: Bool     -- Whether inlining is enabled
@@ -708,19 +782,20 @@ CoreMonad
 
 simplEnvForGHCi :: DynFlags -> SimplEnv
 simplEnvForGHCi dflags
-  = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
-                           , sm_phase = InitialPhase
-                           , sm_rules = rules_on
+  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]
+                           , sm_phase  = InitialPhase
+                           , sm_dflags = dflags
+                           , sm_rules  = rules_on
                            , sm_inline = False
                            , sm_eta_expand = eta_expand_on
-                           , sm_case_case = True }
+                           , sm_case_case  = True }
   where
     rules_on      = gopt Opt_EnableRewriteRules   dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
    -- Do not do any inlining, in case we expose some unboxed
    -- tuple stuff that confuses the bytecode interpreter
 
-updModeForStableUnfoldings :: Activation -> SimplifierMode -> SimplifierMode
+updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
 -- See Note [Simplifying inside stable unfoldings]
 updModeForStableUnfoldings inline_rule_act current_mode
   = current_mode { sm_phase      = phaseFromActivation inline_rule_act
@@ -733,12 +808,12 @@ updModeForStableUnfoldings inline_rule_act current_mode
     phaseFromActivation (ActiveAfter _ n) = Phase n
     phaseFromActivation _                 = InitialPhase
 
-updModeForRules :: SimplifierMode -> SimplifierMode
+updModeForRules :: SimplMode -> SimplMode
 -- See Note [Simplifying rules]
 updModeForRules current_mode
-  = current_mode { sm_phase  = InitialPhase
-                 , sm_inline = False
-                 , sm_rules  = False
+  = current_mode { sm_phase      = InitialPhase
+                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]
+                 , sm_rules      = False
                  , sm_eta_expand = False }
 
 {- Note [Simplifying rules]
@@ -840,7 +915,7 @@ f when it is inlined.  So our conservative plan (implemented by
 updModeForStableUnfoldings) is this:
 
   -------------------------------------------------------------
-  When simplifying the RHS of an stable unfolding, set the phase
+  When simplifying the RHS of a stable unfolding, set the phase
   to the phase in which the stable unfolding first becomes active
   -------------------------------------------------------------
 
@@ -890,8 +965,8 @@ mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
 continuation.
 -}
 
-activeUnfolding :: SimplEnv -> Id -> Bool
-activeUnfolding env id
+activeUnfolding :: SimplMode -> Id -> Bool
+activeUnfolding mode id
   | isCompulsoryUnfolding (realIdUnfolding id)
   = True   -- Even sm_inline can't override compulsory unfoldings
   | otherwise
@@ -902,8 +977,6 @@ activeUnfolding env id
       --  (a) they are active
       --  (b) sm_inline says so, except that for stable unfoldings
       --                         (ie pragmas) we inline anyway
-  where
-    mode = getMode env
 
 getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
 -- When matching in RULE, we want to "look through" an unfolding
@@ -928,13 +1001,11 @@ getUnfoldingInRuleMatch env
      | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
 
 ----------------------
-activeRule :: SimplEnv -> Activation -> Bool
+activeRule :: SimplMode -> Activation -> Bool
 -- Nothing => No rules at all
-activeRule env
+activeRule mode
   | not (sm_rules mode) = \_ -> False     -- Rewriting is off
   | otherwise           = isActive (sm_phase mode)
-  where
-    mode = getMode env
 
 {-
 ************************************************************************
@@ -1017,7 +1088,7 @@ spectral/mandel/Mandel.hs, where the mandelset function gets a useful
 let-float if you inline windowToViewport
 
 However, as usual for Gentle mode, do not inline things that are
-inactive in the intial stages.  See Note [Gentle mode].
+inactive in the initial stages.  See Note [Gentle mode].
 
 Note [Stable unfoldings and preInlineUnconditionally]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1041,6 +1112,11 @@ want PreInlineUnconditionally to second-guess it.  A live example is
 Trac #3736.
     c.f. Note [Stable unfoldings and postInlineUnconditionally]
 
+NB: if the pragama is INLINEABLE, then we don't want to behave int
+this special way -- an INLINEABLE pragam just says to GHC "inline this
+if you like".  But if there is a unique occurrence, we want to inline
+the stable unfolding, not the RHS.
+
 Note [Top-level bottoming Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Don't inline top-level Ids that are bottoming, even if they are used just
@@ -1054,31 +1130,45 @@ is a term (not a coercion) so we can't necessarily inline the latter in
 the former.
 -}
 
-preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
+preInlineUnconditionally
+    :: SimplEnv -> TopLevelFlag -> InId
+    -> InExpr -> StaticEnv  -- These two go together
+    -> Maybe SimplEnv       -- Returned env has extended substitution
 -- Precondition: rhs satisfies the let/app invariant
 -- See Note [CoreSyn let/app invariant] in CoreSyn
 -- Reason: we don't want to inline single uses, or discard dead bindings,
 --         for unlifted, side-effect-ful bindings
-preInlineUnconditionally dflags env top_lvl bndr rhs
-  | not active                               = False
-  | isStableUnfolding (idUnfolding bndr)     = False -- Note [Stable unfoldings and preInlineUnconditionally]
-  | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
-  | not (gopt Opt_SimplPreInlining dflags)   = False
-  | isCoVar bndr                             = False -- Note [Do not inline CoVars unconditionally]
-  | otherwise = case idOccInfo bndr of
-                  IAmDead                    -> True -- Happens in ((\x.1) v)
-                  occ@OneOcc { occ_one_br = True }
-                                             -> try_once (occ_in_lam occ)
-                                                         (occ_int_cxt occ)
-                  _                          -> False
+preInlineUnconditionally env top_lvl bndr rhs rhs_env
+  | not pre_inline_unconditionally           = Nothing
+  | not active                               = Nothing
+  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]
+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]
+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
+                                                       -- in module Exitify
+  | not (one_occ (idOccInfo bndr))           = Nothing
+  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)
+
+  -- Note [Stable unfoldings and preInlineUnconditionally]
+  | isInlinablePragma inline_prag
+  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)
+  | otherwise                                = Nothing
   where
-    mode = getMode env
-    active = isActive (sm_phase mode) act
-             -- See Note [pre/postInlineUnconditionally in gentle mode]
-    act = idInlineActivation bndr
-    try_once in_lam int_cxt     -- There's one textual occurrence
+    unf = idUnfolding bndr
+    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
+
+    one_occ IAmDead = True -- Happens in ((\x.1) v)
+    one_occ (OneOcc { occ_one_br = True      -- One textual occurrence
+                    , occ_in_lam = in_lam
+                    , occ_int_cxt = int_cxt })
         | not in_lam = isNotTopLevel top_lvl || early_phase
         | otherwise  = int_cxt && canInlineInLam rhs
+    one_occ _        = False
+
+    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)
+    mode   = getMode env
+    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)
+             -- See Note [pre/postInlineUnconditionally in gentle mode]
+    inline_prag = idInlinePragma bndr
 
 -- Be very careful before inlining inside a lambda, because (a) we must not
 -- invalidate occurrence information, and (b) we want to avoid pushing a
@@ -1163,18 +1253,16 @@ story for now.
 -}
 
 postInlineUnconditionally
-    :: DynFlags -> SimplEnv -> TopLevelFlag
-    -> OutId            -- The binder (an InId would be fine too)
-                        --            (*not* a CoVar)
+    :: SimplEnv -> TopLevelFlag
+    -> OutId            -- The binder (*not* a CoVar), including its unfolding
     -> OccInfo          -- From the InId
     -> OutExpr
-    -> Unfolding
     -> Bool
 -- Precondition: rhs satisfies the let/app invariant
 -- See Note [CoreSyn let/app invariant] in CoreSyn
 -- Reason: we don't want to inline single uses, or discard dead bindings,
 --         for unlifted, side-effect-ful bindings
-postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding
+postInlineUnconditionally env top_lvl bndr occ_info rhs
   | not active                  = False
   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
                                         -- because it might be referred to "earlier"
@@ -1242,7 +1330,9 @@ postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding
 -- Alas!
 
   where
-    active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
+    unfolding = idUnfolding bndr
+    dflags    = seDynFlags env
+    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
         -- See Note [pre/postInlineUnconditionally in gentle mode]
 
 {-
@@ -1278,7 +1368,7 @@ ones that are trivial):
 
 Note [Stable unfoldings and postInlineUnconditionally]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do not do postInlineUnconditionally if the Id has an stable unfolding,
+Do not do postInlineUnconditionally if the Id has a stable unfolding,
 otherwise we lose the unfolding.  Example
 
      -- f has stable unfolding with rhs (e |> co)
@@ -1414,40 +1504,49 @@ because the latter is not well-kinded.
 ************************************************************************
 -}
 
-tryEtaExpandRhs :: SimplEnv -> RecFlag -> OutId -> OutExpr
-                -> SimplM (Arity, OutExpr)
+tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
+                -> SimplM (Arity, Bool, OutExpr)
 -- See Note [Eta-expanding at let bindings]
-tryEtaExpandRhs env is_rec bndr rhs
-  = do { dflags <- getDynFlags
-       ; (new_arity, new_rhs) <- try_expand dflags
+-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
+--   (a) rhs' has manifest arity
+--   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
+tryEtaExpandRhs mode bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
+       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }
+         -- Note [Do not eta-expand join points]
+         -- But do return the correct arity and bottom-ness, because
+         -- these are used to set the bndr's IdInfo (Trac #15517)
+
+  | otherwise
+  = do { (new_arity, is_bot, new_rhs) <- try_expand
 
        ; WARN( new_arity < old_id_arity,
                (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
                 <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
                         -- Note [Arity decrease] in Simplify
-         return (new_arity, new_rhs) }
+         return (new_arity, is_bot, new_rhs) }
   where
-    try_expand dflags
+    try_expand
       | exprIsTrivial rhs
-      = return (exprArity rhs, rhs)
-
-      | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
-      , let new_arity1 = findRhsArity dflags bndr rhs old_arity
-            new_arity2 = idCallArity bndr
-            new_arity  = max new_arity1 new_arity2
-      , new_arity > old_arity      -- And the current manifest arity isn't enough
-      = if is_rec == Recursive && isJoinId bndr
-           then WARN(True, text "Can't eta-expand recursive join point:" <+>
-                             ppr bndr)
-                return (old_arity, rhs)
-           else do { tick (EtaExpansion bndr)
-                   ; return (new_arity, etaExpand new_arity rhs) }
+      = return (exprArity rhs, False, rhs)
+
+      | sm_eta_expand mode      -- Provided eta-expansion is on
+      , new_arity > old_arity   -- And the current manifest arity isn't enough
+      = do { tick (EtaExpansion bndr)
+           ; return (new_arity, is_bot, etaExpand new_arity rhs) }
+
       | otherwise
-      = return (old_arity, rhs)
+      = return (old_arity, is_bot && new_arity == old_arity, rhs)
 
+    dflags       = sm_dflags mode
     old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
     old_id_arity = idArity bndr
 
+    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity
+    new_arity2 = idCallArity bndr
+    new_arity  = max new_arity1 new_arity2
+
 {-
 Note [Eta-expanding at let bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1473,6 +1572,44 @@ because then 'genMap' will inline, and it really shouldn't: at least
 as far as the programmer is concerned, it's not applied to two
 arguments!
 
+Note [Do not eta-expand join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point
+stands well to gain from its outer binding's eta-expansion, and eta-expanding a
+join point is fraught with issues like how to deal with a cast:
+
+    let join $j1 :: IO ()
+             $j1 = ...
+             $j2 :: Int -> IO ()
+             $j2 n = if n > 0 then $j1
+                              else ...
+
+    =>
+
+    let join $j1 :: IO ()
+             $j1 = (\eta -> ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+             $j2 :: Int -> IO ()
+             $j2 n = (\eta -> if n > 0 then $j1
+                                       else ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+
+The cast here can't be pushed inside the lambda (since it's not casting to a
+function type), so the lambda has to stay, but it can't because it contains a
+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
+than try and detect this situation (and whatever other situations crop up!), we
+don't bother; again, any surrounding eta-expansion will improve these join
+points anyway, since an outer cast can *always* be pushed inside. By the time
+CorePrep comes around, the code is very likely to look more like this:
+
+    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
+             $j1 = (...) eta
+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
+             $j2 = if n > 0 then $j1
+                            else (...) eta
+
 Note [Do not eta-expand PAPs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We used to have old_arity = manifestArity rhs, which meant that we
@@ -1603,22 +1740,25 @@ new binding is abstracted.  Note that
     which is obviously bogus.
 -}
 
-abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
-abstractFloats main_tvs body_env body
+abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats
+              -> OutExpr -> SimplM ([OutBind], OutExpr)
+abstractFloats dflags top_lvl main_tvs floats body
   = ASSERT( notNull body_floats )
+    ASSERT( isNilOL (sfJoinFloats floats) )
     do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
         ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
   where
+    is_top_lvl  = isTopLevel top_lvl
     main_tv_set = mkVarSet main_tvs
-    body_floats = getFloatBinds body_env
-    empty_subst = CoreSubst.mkEmptySubst (seInScope body_env)
+    body_floats = letFloatBinds (sfLetFloats floats)
+    empty_subst = CoreSubst.mkEmptySubst (sfInScope floats)
 
     abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
     abstract subst (NonRec id rhs)
-      = do { (poly_id, poly_app) <- mk_poly tvs_here id
-           ; let poly_rhs = mkLams tvs_here rhs'
-                 subst'   = CoreSubst.extendIdSubst subst id poly_app
-           ; return (subst', (NonRec poly_id poly_rhs)) }
+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
+                 subst' = CoreSubst.extendIdSubst subst id poly_app
+           ; return (subst', NonRec poly_id2 poly_rhs) }
       where
         rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
 
@@ -1629,11 +1769,13 @@ abstractFloats main_tvs body_env body
                    exprSomeFreeVarsList isTyVar rhs'
 
     abstract subst (Rec prs)
-       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
             ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
-                  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs)
-                              | rhs <- rhss]
-            ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
+                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+                               | (poly_id, rhs) <- poly_ids `zip` rhss
+                               , let rhs' = CoreSubst.substExpr (text "abstract_floats")
+                                                                subst' rhs ]
+            ; return (subst', Rec poly_pairs) }
        where
          (ids,rhss) = unzip prs
                 -- For a recursive group, it's a bit of a pain to work out the minimal
@@ -1651,7 +1793,8 @@ abstractFloats main_tvs body_env body
                 -- Here, we must abstract 'x' over 'a'.
          tvs_here = toposortTyVars main_tvs
 
-    mk_poly tvs_here var
+    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
+    mk_poly1 tvs_here var
       = do { uniq <- getUniqueM
            ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
                   poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course
@@ -1671,6 +1814,21 @@ abstractFloats main_tvs body_env body
                 -- the occurrences of x' will be just the occurrences originally
                 -- pinned on x.
 
+    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
+    mk_poly2 poly_id tvs_here rhs
+      = (poly_id `setIdUnfolding` unf, poly_rhs)
+      where
+        poly_rhs = mkLams tvs_here rhs
+        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs
+
+        -- We want the unfolding.  Consider
+        --      let
+        --            x = /\a. let y = ... in Just y
+        --      in body
+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)
+        -- but 'x' may well then be inlined in 'body' in which case we'd like the
+        -- opportunity to inline 'y' too.
+
 {-
 Note [Abstract over coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1785,7 +1943,7 @@ prepareAlts scrut case_bndr' alts
 mkCase tries these things
 
 * Note [Nerge nested cases]
-* Note [Elimiante identity case]
+* Note [Eliminate identity case]
 * Note [Scrutinee constant folding]
 
 Note [Merge Nested Cases]
@@ -1985,13 +2143,18 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
 
 mkCase2 dflags scrut bndr alts_ty alts
   | -- See Note [Scrutinee Constant Folding]
-    case alts of  -- Not if there is just a DEFAULT alterantive
+    case alts of  -- Not if there is just a DEFAULT alternative
       [(DEFAULT,_,_)] -> False
       _               -> True
   , gopt Opt_CaseFolding dflags
   , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut
   = do { bndr' <- newId (fsLit "lwild") (exprType scrut')
-       ; alts' <- mapM  (tx_alt tx_con mk_orig bndr') alts
+
+       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
+                  -- mapMaybeM: discard unreachable alternatives
+                  -- See Note [Unreachable caseRules alternatives]
+                  -- in PrelRules
+
        ; mkCase3 dflags scrut' bndr' alts_ty $
          add_default (re_sort alts')
        }
@@ -2015,19 +2178,14 @@ mkCase2 dflags scrut bndr alts_ty alts
     -- to construct an expression equivalent to the original one, for use
     -- in the DEFAULT case
 
+    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
+           -> CoreAlt -> SimplM (Maybe CoreAlt)
     tx_alt tx_con mk_orig new_bndr (con, bs, rhs)
-      | DataAlt dc <- con', not (isNullaryRepDataCon dc)
-      = -- For non-nullary data cons we must invent some fake binders
-        -- See Note [caseRules for dataToTag] in PrelRules
-        do { us <- getUniquesM
-           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc
-                                         (tyConAppArgs (idType new_bndr))
-           ; return (con', ex_tvs ++ arg_ids, rhs') }
-      | otherwise
-      = return (con', [], rhs')
+      = case tx_con con of
+          Nothing   -> return Nothing
+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'
+                          ; return (Just (con', bs', rhs')) }
       where
-        con' = tx_con con
-
         rhs' | isDeadBinder bndr = rhs
              | otherwise         = bindNonRec bndr orig_val rhs
 
@@ -2036,23 +2194,61 @@ mkCase2 dflags scrut bndr alts_ty alts
                       LitAlt l   -> Lit l
                       DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs
 
+    mk_new_bndrs new_bndr (DataAlt dc)
+      | not (isNullaryRepDataCon dc)
+      = -- For non-nullary data cons we must invent some fake binders
+        -- See Note [caseRules for dataToTag] in PrelRules
+        do { us <- getUniquesM
+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc
+                                        (tyConAppArgs (idType new_bndr))
+           ; return (ex_tvs ++ arg_ids) }
+    mk_new_bndrs _ _ = return []
 
     re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to
     re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#
 
     add_default :: [CoreAlt] -> [CoreAlt]
-    -- TagToEnum may change a boolean True/False set of alternatives
-    -- to LitAlt 0#/1# alterantives.  But literal alternatives always
-    -- have a DEFAULT (I think).  So add it.
+    -- See Note [Literal cases]
     add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts
     add_default alts                          = alts
 
+{- Note [Literal cases]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  case tagToEnum (a ># b) of
+     False -> e1
+     True  -> e2
+
+then caseRules for TagToEnum will turn it into
+  case tagToEnum (a ># b) of
+     0# -> e1
+     1# -> e2
+
+Since the case is exhaustive (all cases are) we can convert it to
+  case tagToEnum (a ># b) of
+     DEFAULT -> e1
+     1#      -> e2
+
+This may generate sligthtly better code (although it should not, since
+all cases are exhaustive) and/or optimise better.  I'm not certain that
+it's necessary, but currenty we do make this change.  We do it here,
+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]
+in PrelRules)
+-}
+
 --------------------------------------------------
 --      Catch-all
 --------------------------------------------------
 mkCase3 _dflags scrut bndr alts_ty alts
   = return (Case scrut bndr alts_ty alts)
 
+-- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs
+-- This lives here (and not in Id) because occurrence info is only valid on
+-- InIds, so it's crucial that isExitJoinId is only called on freshly
+-- occ-analysed code. It's not a generic function you can call anywhere.
+isExitJoinId :: Var -> Bool
+isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)
+
 {-
 Note [Dead binders]
 ~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 91ed644057..872973925f 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -10,6 +10,8 @@ module Simplify ( simplTopBinds, simplExpr, simplRules ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import SimplMonad
 import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )
@@ -22,29 +24,28 @@ import Id
 import MkId             ( seqId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
 import IdInfo
-import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )
+import Name             ( mkSystemVarName, isExternalName, getOccFS )
 import Coercion hiding  ( substCo, substCoVar )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType_maybe )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys )
---import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
-import CoreMonad        ( Tick(..), SimplifierMode(..) )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
+                        , dataConRepArgTys, isUnboxedTupleCon
+                        , StrictnessMark (..) )
+import CoreMonad        ( Tick(..), SimplMode(..) )
 import CoreSyn
 import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd )
 import PprCore          ( pprCoreExpr )
 import CoreUnfold
 import CoreUtils
-import CoreArity
 import CoreOpt          ( pushCoTyArg, pushCoValArg
                         , joinPointBinding_maybe, joinPointBindings_maybe )
---import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
 import Rules            ( mkRuleInfo, lookupRule, getRules )
---import TysPrim          ( intPrimTy ) -- temporalily commented out. See #8326
+import Demand           ( mkClosedStrictSig, topDmd, exnRes )
 import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
-                          RecFlag(..) )
-import MonadUtils       ( foldlM, mapAccumLM, liftIO )
-import Maybes           ( isJust, fromJust, orElse, catMaybes )
---import Unique           ( hasKey ) -- temporalily commented out. See #8326
+                          RecFlag(..), Arity )
+import MonadUtils       ( mapAccumLM, liftIO )
+import Var              ( isTyCoVar )
+import Maybes           (  orElse )
 import Control.Monad
 import Outputable
 import FastString
@@ -52,147 +53,57 @@ import Pair
 import Util
 import ErrUtils
 import Module          ( moduleName, pprModuleName )
+import PrimOp          ( PrimOp (SeqOp) )
+
 
 {-
 The guts of the simplifier is in this module, but the driver loop for
 the simplifier is in SimplCore.hs.
 
+Note [The big picture]
+~~~~~~~~~~~~~~~~~~~~~~
+The general shape of the simplifier is this:
 
------------------------------------------
-        *** IMPORTANT NOTE ***
------------------------------------------
-The simplifier used to guarantee that the output had no shadowing, but
-it does not do so any more.   (Actually, it never did!)  The reason is
-documented with simplifyArgs.
-
-
------------------------------------------
-        *** IMPORTANT NOTE ***
------------------------------------------
-Many parts of the simplifier return a bunch of "floats" as well as an
-expression. This is wrapped as a datatype SimplUtils.FloatsWith.
-
-All "floats" are let-binds, not case-binds, but some non-rec lets may
-be unlifted (with RHS ok-for-speculation).
-
-
-
------------------------------------------
-        ORGANISATION OF FUNCTIONS
------------------------------------------
-simplTopBinds
-  - simplify all top-level binders
-  - for NonRec, call simplRecOrTopPair
-  - for Rec,    call simplRecBind
-
-
-        ------------------------------
-simplExpr (applied lambda)      ==> simplNonRecBind
-simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
-simplExpr (Let (Rec ...)    ..) ==> simplify binders; simplRecBind
-
-        ------------------------------
-simplRecBind    [binders already simplfied]
-  - use simplRecOrTopPair on each pair in turn
-
-simplRecOrTopPair [binder already simplified]
-  Used for: recursive bindings (top level and nested)
-            top-level non-recursive bindings
-  Returns:
-  - check for PreInlineUnconditionally
-  - simplLazyBind
-
-simplNonRecBind
-  Used for: non-top-level non-recursive bindings
-            beta reductions (which amount to the same thing)
-  Because it can deal with strict arts, it takes a
-        "thing-inside" and returns an expression
-
-  - check for PreInlineUnconditionally
-  - simplify binder, including its IdInfo
-  - if strict binding
-        simplStrictArg
-        mkAtomicArgs
-        completeNonRecX
-    else
-        simplLazyBind
-        addFloats
-
-simplNonRecX:   [given a *simplified* RHS, but an *unsimplified* binder]
-  Used for: binding case-binder and constr args in a known-constructor case
-  - check for PreInLineUnconditionally
-  - simplify binder
-  - completeNonRecX
-
-        ------------------------------
-simplLazyBind:  [binder already simplified, RHS not]
-  Used for: recursive bindings (top level and nested)
-            top-level non-recursive bindings
-            non-top-level, but *lazy* non-recursive bindings
-        [must not be strict or unboxed]
-  Returns floats + an augmented environment, not an expression
-  - substituteIdInfo and add result to in-scope
-        [so that rules are available in rec rhs]
-  - simplify rhs
-  - mkAtomicArgs
-  - float if exposes constructor or PAP
-  - completeBind
-
-
-completeNonRecX:        [binder and rhs both simplified]
-  - if the the thing needs case binding (unlifted and not ok-for-spec)
-        build a Case
-   else
-        completeBind
-        addFloats
-
-completeBind:   [given a simplified RHS]
-        [used for both rec and non-rec bindings, top level and not]
-  - try PostInlineUnconditionally
-  - add unfolding [this is the only place we add an unfolding]
-  - add arity
-
-
-
-Right hand sides and arguments
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In many ways we want to treat
-        (a) the right hand side of a let(rec), and
-        (b) a function argument
-in the same way.  But not always!  In particular, we would
-like to leave these arguments exactly as they are, so they
-will match a RULE more easily.
-
-        f (g x, h x)
-        g (+ x)
-
-It's harder to make the rule match if we ANF-ise the constructor,
-or eta-expand the PAP:
+  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
 
-        f (let { a = g x; b = h x } in (a,b))
-        g (\y. + x y)
+ * SimplEnv contains
+     - Simplifier mode (which includes DynFlags for convenience)
+     - Ambient substitution
+     - InScopeSet
 
-On the other hand if we see the let-defns
+ * SimplFloats contains
+     - Let-floats (which includes ok-for-spec case-floats)
+     - Join floats
+     - InScopeSet (including all the floats)
 
-        p = (g x, h x)
-        q = + x
+ * Expressions
+      simplExpr :: SimplEnv -> InExpr -> SimplCont
+                -> SimplM (SimplFloats, OutExpr)
+   The result of simplifying an /expression/ is (floats, expr)
+      - A bunch of floats (let bindings, join bindings)
+      - A simplified expression.
+   The overall result is effectively (let floats in expr)
 
-then we *do* want to ANF-ise and eta-expand, so that p and q
-can be safely inlined.
+ * Bindings
+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+   The result of simplifying a binding is
+     - A bunch of floats, the last of which is the simplified binding
+       There may be auxiliary bindings too; see prepareRhs
+     - An environment suitable for simplifying the scope of the binding
 
-Even floating lets out is a bit dubious.  For let RHS's we float lets
-out if that exposes a value, so that the value can be inlined more vigorously.
-For example
+   The floats may also be empty, if the binding is inlined unconditionally;
+   in that case the returned SimplEnv will have an augmented substitution.
 
-        r = let x = e in (x,x)
+   The returned floats and env both have an in-scope set, and they are
+   guaranteed to be the same.
 
-Here, if we float the let out we'll expose a nice constructor. We did experiments
-that showed this to be a generally good thing.  But it was a bad thing to float
-lets out unconditionally, because that meant they got allocated more often.
 
-For function arguments, there's less reason to expose a constructor (it won't
-get inlined).  Just possibly it might make a rule match, but I'm pretty skeptical.
-So for the moment we don't float lets out of function arguments either.
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more.   (Actually, it never did!)  The reason is
+documented with simplifyArgs.
 
 
 Eta expansion
@@ -206,36 +117,6 @@ lambdas together.  And in general that's a good thing to do.  Perhaps
 we should eta expand wherever we find a (value) lambda?  Then the eta
 expansion at a let RHS can concentrate solely on the PAP case.
 
-
-Case-of-case and join points
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we perform the case-of-case transform (or otherwise push continuations
-inward), we want to treat join points specially. Since they're always
-tail-called and we want to maintain this invariant, we can do this (for any
-evaluation context E):
-
-  E[join j = e
-    in case ... of
-         A -> jump j 1
-         B -> jump j 2
-         C -> f 3]
-
-    -->
-
-  join j = E[e]
-  in case ... of
-       A -> jump j 1
-       B -> jump j 2
-       C -> E[f 3]
-
-As is evident from the example, there are two components to this behavior:
-
-  1. When entering the RHS of a join point, copy the context inside.
-  2. When a join point is invoked, discard the outer context.
-
-Clearly we need to be very careful here to remain consistent---neither part is
-optional!
-
 ************************************************************************
 *                                                                      *
 \subsection{Bindings}
@@ -243,38 +124,39 @@ optional!
 ************************************************************************
 -}
 
-simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
-
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+-- See Note [The big picture]
 simplTopBinds env0 binds0
   = do  {       -- Put all the top-level binders into scope at the start
                 -- so that if a transformation rule has unexpectedly brought
                 -- anything into scope, then we don't get a complaint about that.
                 -- It's rather as if the top-level binders were imported.
                 -- See note [Glomming] in OccurAnal.
-        ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0)
-        ; env2 <- simpl_binds env1 binds0
+        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
         ; freeTick SimplifierDone
-        ; return env2 }
+        ; return (floats, env2) }
   where
         -- We need to track the zapped top-level binders, because
         -- they should have their fragile IdInfo zapped (notably occurrence info)
         -- That's why we run down binds and bndrs' simultaneously.
         --
-    simpl_binds :: SimplEnv -> [InBind] -> SimplM SimplEnv
-    simpl_binds env []           = return env
-    simpl_binds env (bind:binds) = do { env' <- simpl_bind env bind
-                                      ; simpl_binds env' binds }
-
-    simpl_bind env (Rec pairs)  = simplRecBind env TopLevel Nothing pairs
-    simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)
-                                     ; simplRecOrTopPair env' TopLevel
-                                                         NonRecursive Nothing
-                                                         b b' r }
+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+    simpl_binds env []           = return (emptyFloats env, env)
+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
+                                      ; (floats, env2) <- simpl_binds env1 binds
+                                      ; return (float `addFloats` floats, env2) }
+
+    simpl_bind env (Rec pairs)
+      = simplRecBind env TopLevel Nothing pairs
+    simpl_bind env (NonRec b r)
+      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing
+           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }
 
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Lazy bindings}
+        Lazy bindings
 *                                                                      *
 ************************************************************************
 
@@ -282,28 +164,27 @@ simplRecBind is used for
         * recursive bindings only
 -}
 
-simplRecBind :: SimplEnv -> TopLevelFlag -> Maybe SimplCont
+simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont
              -> [(InId, InExpr)]
-             -> SimplM SimplEnv
+             -> SimplM (SimplFloats, SimplEnv)
 simplRecBind env0 top_lvl mb_cont pairs0
   = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
-        ; env1 <- go (zapFloats env_with_info) triples
-        ; return (env0 `addRecFloats` env1) }
-        -- addRecFloats adds the floats from env1,
-        -- _and_ updates env0 with the in-scope set from env1
+        ; (rec_floats, env1) <- go env_with_info triples
+        ; return (mkRecFloats rec_floats, env1) }
   where
     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
         -- Add the (substituted) rules to the binder
     add_rules env (bndr, rhs)
-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr)
+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont
              ; return (env', (bndr, bndr', rhs)) }
 
-    go env [] = return env
+    go env [] = return (emptyFloats env, env)
 
     go env ((old_bndr, new_bndr, rhs) : pairs)
-        = do { env' <- simplRecOrTopPair env top_lvl Recursive mb_cont
-                                         old_bndr new_bndr rhs
-             ; go env' pairs }
+        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont
+                                                  old_bndr new_bndr rhs
+             ; (floats, env2) <- go env1 pairs
+             ; return (float `addFloats` floats, env2) }
 
 {-
 simplOrTopPair is used for
@@ -314,59 +195,40 @@ It assumes the binder has already been simplified, but not its IdInfo.
 -}
 
 simplRecOrTopPair :: SimplEnv
-                  -> TopLevelFlag -> RecFlag -> Maybe SimplCont
+                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont
                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
-                  -> SimplM SimplEnv    -- Returns an env that includes the binding
+                  -> SimplM (SimplFloats, SimplEnv)
 
 simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
-  = do { dflags <- getDynFlags
-       ; trace_bind dflags $
-           if preInlineUnconditionally dflags env top_lvl old_bndr rhs
-                    -- Check for unconditional inline
-           then do tick (PreInlineUnconditionally old_bndr)
-                   return (extendIdSubst env old_bndr (mkContEx env rhs))
-           else simplBind env top_lvl is_rec mb_cont old_bndr new_bndr rhs env }
+  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env
+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
+    trace_bind "pre-inline-uncond" $
+    do { tick (PreInlineUnconditionally old_bndr)
+       ; return ( emptyFloats env, env' ) }
+
+  | Just cont <- mb_cont
+  = {-#SCC "simplRecOrTopPair-join" #-}
+    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )
+    trace_bind "join" $
+    simplJoinBind env cont old_bndr new_bndr rhs env
+
+  | otherwise
+  = {-#SCC "simplRecOrTopPair-normal" #-}
+    trace_bind "normal" $
+    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
+
   where
-    trace_bind dflags thing_inside
+    dflags = seDynFlags env
+
+    -- trace_bind emits a trace for each top-level binding, which
+    -- helps to locate the tracing for inlining and rule firing
+    trace_bind what thing_inside
       | not (dopt Opt_D_verbose_core2core dflags)
       = thing_inside
       | otherwise
-      = pprTrace "SimplBind" (ppr old_bndr) thing_inside
-        -- trace_bind emits a trace for each top-level binding, which
-        -- helps to locate the tracing for inlining and rule firing
-
-{-
-simplBind is used for
-  * [simplRecOrTopPair] recursive bindings (whether top level or not)
-  * [simplRecOrTopPair] top-level non-recursive bindings
-  * [simplNonRecE]      non-top-level *lazy* non-recursive bindings
-
-Nota bene:
-    1. It assumes that the binder is *already* simplified,
-       and is in scope, and its IdInfo too, except unfolding
-
-    2. It assumes that the binder type is lifted.
-
-    3. It does not check for pre-inline-unconditionally;
-       that should have been done already.
--}
-
-simplBind :: SimplEnv
-          -> TopLevelFlag -> RecFlag -> Maybe SimplCont
-          -> InId -> OutId      -- Binder, both pre-and post simpl
-                                -- Can be a JoinId
-                                -- The OutId has IdInfo, except arity, unfolding
-                                -- Ids only, no TyVars
-          -> InExpr -> SimplEnv -- The RHS and its environment
-          -> SimplM SimplEnv
-simplBind env top_lvl is_rec mb_cont bndr bndr1 rhs rhs_se
-  | ASSERT( isId bndr1 )
-    isJoinId bndr1
-  = ASSERT(isNotTopLevel top_lvl && isJust mb_cont)
-    simplJoinBind env is_rec (fromJust mb_cont) bndr bndr1 rhs rhs_se
-  | otherwise
-  = simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside
 
+--------------------------
 simplLazyBind :: SimplEnv
               -> TopLevelFlag -> RecFlag
               -> InId -> OutId          -- Binder, both pre-and post simpl
@@ -374,7 +236,7 @@ simplLazyBind :: SimplEnv
                                         -- The OutId has IdInfo, except arity, unfolding
                                         -- Ids only, no TyVars
               -> InExpr -> SimplEnv     -- The RHS and its environment
-              -> SimplM SimplEnv
+              -> SimplM (SimplFloats, SimplEnv)
 -- Precondition: not a JoinId
 -- Precondition: rhs obeys the let/app invariant
 -- NOT used for JoinIds
@@ -382,7 +244,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
   = ASSERT( isId bndr )
     ASSERT2( not (isJoinId bndr), ppr bndr )
     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
-    do  { let   rhs_env     = rhs_se `setInScopeAndZapFloats` env
+    do  { let   rhs_env     = rhs_se `setInScopeFromE` env
                 (tvs, body) = case collectTyAndValBinders rhs of
                                 (tvs, [], body)
                                   | surely_not_lam body -> (tvs, body)
@@ -399,151 +261,120 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                         -- should eta-reduce.
 
 
-        ; (body_env, tvs') <- simplBinders rhs_env tvs
+        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
         ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
-        ; (body_env0, body0) <- simplExprF body_env body rhs_cont
-        ; let (body_env1, body1) = wrapJoinFloatsX body_env0 body0
-
-        -- ANF-ise a constructor or PAP rhs
-        ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont
 
-        -- We need body_env2 for its let-floats (only);
-        -- we've dealt with its join-floats, which are now empty
-        ; (env', rhs')
-            <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
-                then                            -- No floating, revert to body1
-                     do { rhs' <- mkLam env tvs' (wrapFloats body_env1 body1) rhs_cont
-                        ; return (env, rhs') }
+              -- Never float join-floats out of a non-join let-binding
+              -- So wrap the body in the join-floats right now
+              -- Henc: body_floats1 consists only of let-floats
+        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0
 
-                else if null tvs then           -- Simple floating
+        -- ANF-ise a constructor or PAP rhs
+        -- We get at most one float per argument here
+        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl
+                                            (getOccFS bndr1) (idInfo bndr1) body1
+        ; let body_floats2 = body_floats1 `addLetFloats` let_floats
+
+        ; (rhs_floats, rhs')
+            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)
+                then                    -- No floating, revert to body1
+                     {-#SCC "simplLazyBind-no-floating" #-}
+                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont
+                        ; return (emptyFloats env, rhs') }
+
+                else if null tvs then   -- Simple floating
+                     {-#SCC "simplLazyBind-simple-floating" #-}
                      do { tick LetFloatFromLet
-                        ; return (addLetFloats env body_env2, body2) }
+                        ; return (body_floats2, body2) }
 
-                else                            -- Do type-abstraction first
+                else                    -- Do type-abstraction first
+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}
                      do { tick LetFloatFromLet
-                        ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2
+                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl
+                                                                tvs' body_floats2 body2
+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds
                         ; rhs' <- mkLam env tvs' body3 rhs_cont
-                        ; env' <- foldlM (addPolyBind top_lvl) env poly_binds
-                        ; return (env', rhs') }
+                        ; return (floats, rhs') }
 
-        ; completeBind env' top_lvl is_rec Nothing bndr bndr1 rhs' }
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             top_lvl Nothing bndr bndr1 rhs'
+        ; return (rhs_floats `addFloats` bind_float, env2) }
 
+--------------------------
 simplJoinBind :: SimplEnv
-              -> RecFlag
               -> SimplCont
               -> InId -> OutId          -- Binder, both pre-and post simpl
                                         -- The OutId has IdInfo, except arity,
                                         --   unfolding
-              -> InExpr -> SimplEnv     -- The RHS and its environment
-              -> SimplM SimplEnv
-simplJoinBind env is_rec cont bndr bndr1 rhs rhs_se
-  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$
-    --                           ppr rhs $$ ppr (seIdSubst rhs_se)) $
-    do  { let rhs_env = rhs_se `setInScopeAndZapFloats` env
-        ; rhs' <- simplJoinRhs rhs_env bndr rhs cont
-        ; completeBind env NotTopLevel is_rec (Just cont) bndr bndr1 rhs' }
-
-{-
-A specialised variant of simplNonRec used when the RHS is already simplified,
-notably in knownCon.  It uses case-binding where necessary.
--}
-
+              -> InExpr -> SimplEnv     -- The right hand side and its env
+              -> SimplM (SimplFloats, SimplEnv)
+simplJoinBind env cont old_bndr new_bndr rhs rhs_se
+  = do  { let rhs_env = rhs_se `setInScopeFromE` env
+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont
+        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }
+
+--------------------------
 simplNonRecX :: SimplEnv
              -> InId            -- Old binder; not a JoinId
              -> OutExpr         -- Simplified RHS
-             -> SimplM SimplEnv
+             -> SimplM (SimplFloats, SimplEnv)
+-- A specialised variant of simplNonRec used when the RHS is already
+-- simplified, notably in knownCon.  It uses case-binding where necessary.
+--
 -- Precondition: rhs satisfies the let/app invariant
+
 simplNonRecX env bndr new_rhs
   | ASSERT2( not (isJoinId bndr), ppr bndr )
     isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
-  = return env    --  Here c is dead, and we avoid creating
-                  --   the binding c = (a,b)
+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid
+                                         --  creating the binding c = (a,b)
 
   | Coercion co <- new_rhs
-  = return (extendCvSubst env bndr co)
+  = return (emptyFloats env, extendCvSubst env bndr co)
 
   | otherwise
   = do  { (env', bndr') <- simplBinder env bndr
         ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
                 -- simplNonRecX is only used for NotTopLevel things
 
+--------------------------
 completeNonRecX :: TopLevelFlag -> SimplEnv
                 -> Bool
                 -> InId                 -- Old binder; not a JoinId
                 -> OutId                -- New binder
                 -> OutExpr              -- Simplified RHS
-                -> SimplM SimplEnv      -- The new binding extends the seLetFloats
-                                        -- of the resulting SimpleEnv
+                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats
 -- Precondition: rhs satisfies the let/app invariant
 --               See Note [CoreSyn let/app invariant] in CoreSyn
 
 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
   = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )
-    do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
-        ; (env2, rhs2) <-
-                if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
-                then do { tick LetFloatFromLet
-                        ; return (addLetFloats env env1, rhs1) }   -- Add the floats to the main env
-                else return (env, wrapFloats env1 rhs1)         -- Wrap the floats around the RHS
-        ; completeBind env2 NotTopLevel NonRecursive Nothing
-                       old_bndr new_bndr rhs2 }
-
-{- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
-   Doing so risks exponential behaviour, because new_rhs has been simplified once already
-   In the cases described by the following comment, postInlineUnconditionally will
-   catch many of the relevant cases.
-        -- This happens; for example, the case_bndr during case of
-        -- known constructor:  case (a,b) of x { (p,q) -> ... }
-        -- Here x isn't mentioned in the RHS, so we don't want to
-        -- create the (dead) let-binding  let x = (a,b) in ...
-        --
-        -- Similarly, single occurrences can be inlined vigourously
-        -- e.g.  case (f x, g y) of (a,b) -> ....
-        -- If a,b occur once we can avoid constructing the let binding for them.
-
-   Furthermore in the case-binding case preInlineUnconditionally risks extra thunks
-        -- Consider     case I# (quotInt# x y) of
-        --                I# v -> let w = J# v in ...
-        -- If we gaily inline (quotInt# x y) for v, we end up building an
-        -- extra thunk:
-        --                let w = J# (quotInt# x y) in ...
-        -- because quotInt# can fail.
-
-  | preInlineUnconditionally env NotTopLevel bndr new_rhs
-  = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
--}
-
-----------------------------------
-{- Note [Avoiding exponential behaviour]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-One way in which we can get exponential behaviour is if we simplify a
-big expression, and the re-simplify it -- and then this happens in a
-deeply-nested way.  So we must be jolly careful about re-simplifying
-an expression.  That is why completeNonRecX does not try
-preInlineUnconditionally.
-
-Example:
-  f BIG, where f has a RULE
-Then
- * We simplify BIG before trying the rule; but the rule does not fire
- * We inline f = \x. x True
- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)
+    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)
+                                             (idInfo new_bndr) new_rhs
+        ; let floats = emptyFloats env `addLetFloats` prepd_floats
+        ; (rhs_floats, rhs2) <-
+                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1
+                then    -- Add the floats to the main env
+                     do { tick LetFloatFromLet
+                        ; return (floats, rhs1) }
+                else    -- Do not float; wrap the floats around the RHS
+                     return (emptyFloats env, wrapFloats floats rhs1)
 
-However, if BIG has /not/ already been simplified, we'd /like/ to
-simplify BIG True; maybe good things happen.  That is why
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             NotTopLevel Nothing
+                                             old_bndr new_bndr rhs2
+        ; return (rhs_floats `addFloats` bind_float, env2) }
 
-* simplLam has
-    - a case for (isSimplified dup), which goes via simplNonRecX, and
-    - a case for the un-simplified case, which goes via simplNonRecE
 
-* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,
-  in at least two places
-    - In simplCast/addCoerce, where we check for isReflCo
-    - In rebuildCall we avoid simplifying arguments before we have to
-      (see Note [Trying rewrite rules])
+{- *********************************************************************
+*                                                                      *
+           prepareRhs, makeTrivial
+*                                                                      *
+************************************************************************
 
 Note [prepareRhs]
 ~~~~~~~~~~~~~~~~~
@@ -563,71 +394,68 @@ Here we want to make e1,e2 trivial and get
 That's what the 'go' loop in prepareRhs does
 -}
 
-prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
--- See Note [prepareRhs]
--- Adds new floats to the env iff that allows us to return a good RHS
+prepareRhs :: SimplMode -> TopLevelFlag
+           -> FastString   -- Base for any new variables
+           -> IdInfo       -- IdInfo for the LHS of this binding
+           -> OutExpr
+           -> SimplM (LetFloats, OutExpr)
+-- Transforms a RHS into a better RHS by adding floats
+-- e.g        x = Just e
+-- becomes    a = e
+--            x = Just a
 -- See Note [prepareRhs]
-prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
-  | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
-  , not (isUnliftedType ty1)            -- see Note [Float coercions (unlifted)]
-  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env (getOccFS id) sanitised_info rhs
-        ; return (env', Cast rhs' co) }
+prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]
+  | Pair ty1 _ty2 <- coercionKind co         -- Do *not* do this if rhs has an unlifted type
+  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]
+  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs
+        ; return (floats, Cast rhs' co) }
   where
     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
-                                   `setDemandInfo` demandInfo info
-    info = idInfo id
+                                   `setDemandInfo`     demandInfo info
 
-prepareRhs top_lvl env0 id rhs0
-  = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
-        ; return (env1, rhs1) }
+prepareRhs mode top_lvl occ _ rhs0
+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0
+        ; return (floats, rhs1) }
   where
-    go n_val_args env (Cast rhs co)
-        = do { (is_exp, env', rhs') <- go n_val_args env rhs
-             ; return (is_exp, env', Cast rhs' co) }
-    go n_val_args env (App fun (Type ty))
-        = do { (is_exp, env', rhs') <- go n_val_args env fun
-             ; return (is_exp, env', App rhs' (Type ty)) }
-    go n_val_args env (App fun arg)
-        = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
+    go n_val_args (Cast rhs co)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Cast rhs' co) }
+    go n_val_args (App fun (Type ty))
+        = do { (is_exp, floats, rhs') <- go n_val_args fun
+             ; return (is_exp, floats, App rhs' (Type ty)) }
+    go n_val_args (App fun arg)
+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
              ; case is_exp of
-                True -> do { (env'', arg') <- makeTrivial top_lvl env' (getOccFS id) arg
-                           ; return (True, env'', App fun' arg') }
-                False -> return (False, env, App fun arg) }
-    go n_val_args env (Var fun)
-        = return (is_exp, env, Var fun)
+                False -> return (False, emptyLetFloats, App fun arg)
+                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg
+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }
+    go n_val_args (Var fun)
+        = return (is_exp, emptyLetFloats, Var fun)
         where
           is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
                         -- See Note [CONLIKE pragma] in BasicTypes
                         -- The definition of is_exp should match that in
                         -- OccurAnal.occAnalApp
 
-    go n_val_args env (Tick t rhs)
+    go n_val_args (Tick t rhs)
         -- We want to be able to float bindings past this
         -- tick. Non-scoping ticks don't care.
         | tickishScoped t == NoScope
-        = do { (is_exp, env', rhs') <- go n_val_args env rhs
-             ; return (is_exp, env', Tick t rhs') }
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Tick t rhs') }
 
         -- On the other hand, for scoping ticks we need to be able to
         -- copy them on the floats, which in turn is only allowed if
         -- we can obtain non-counting ticks.
         | (not (tickishCounts t) || tickishCanSplit t)
-        = do { (is_exp, env', rhs') <- go n_val_args (zapFloats env) rhs
-                    -- env' has the extra let-bindings from
-                    -- the makeTrivial calls in 'go'; no join floats
-             ; let tickIt (id, expr)
-                       -- we have to take care not to tick top-level literal
-                       -- strings. See Note [CoreSyn top-level string literals].
-                     | isTopLevel top_lvl && exprIsLiteralString expr
-                     = (id, expr)
-                     | otherwise
-                     = (id, mkTick (mkNoCount t) expr)
-                   floats' = seLetFloats env `addFlts`
-                             mapFloats (seLetFloats env') tickIt
-             ; return (is_exp, env' { seLetFloats = floats' }, Tick t rhs') }
-
-    go _ env other
-        = return (False, env, other)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+                   floats' = mapLetFloats floats tickIt
+             ; return (is_exp, floats', Tick t rhs') }
+
+    go _ other
+        = return (False, emptyLetFloats, other)
 
 {-
 Note [Float coercions]
@@ -680,50 +508,55 @@ These strange casts can happen as a result of case-of-case
                 (# p,q #) -> p+q
 -}
 
-makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
-makeTrivialArg env (ValArg e) = do
-    { (env', e') <- makeTrivial NotTopLevel env (fsLit "arg") e
-    ; return (env', ValArg e') }
-makeTrivialArg env arg        = return (env, arg)  -- CastBy, TyArg
-
-makeTrivial :: TopLevelFlag -> SimplEnv
-            -> FastString  -- ^ a "friendly name" to build the new binder from
-            -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
+makeTrivialArg mode (ValArg e)
+  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
+       ; return (floats, ValArg e') }
+makeTrivialArg _ arg
+  = return (emptyLetFloats, arg)  -- CastBy, TyArg
+
+makeTrivial :: SimplMode -> TopLevelFlag
+            -> FastString  -- ^ A "friendly name" to build the new binder from
+            -> OutExpr     -- ^ This expression satisfies the let/app invariant
+            -> SimplM (LetFloats, OutExpr)
 -- Binds the expression to a variable, if it's not trivial, returning the variable
-makeTrivial top_lvl env context expr =
-    makeTrivialWithInfo top_lvl env context vanillaIdInfo expr
-
-makeTrivialWithInfo :: TopLevelFlag -> SimplEnv
-                    -> FastString
-                    -- ^ a "friendly name" to build the new binder from
-                    -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivial mode top_lvl context expr
+ = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr
+
+makeTrivialWithInfo :: SimplMode -> TopLevelFlag
+                    -> FastString  -- ^ a "friendly name" to build the new binder from
+                    -> IdInfo
+                    -> OutExpr     -- ^ This expression satisfies the let/app invariant
+                    -> SimplM (LetFloats, OutExpr)
 -- Propagate strictness and demand info to the new binder
 -- Note [Preserve strictness when floating coercions]
 -- Returned SimplEnv has same substitution as incoming one
-makeTrivialWithInfo top_lvl env context info expr
+makeTrivialWithInfo mode top_lvl occ_fs info expr
   | exprIsTrivial expr                          -- Already trivial
   || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                 --   See Note [Cannot trivialise]
-  = return (env, expr)
-
-  | otherwise           -- See Note [Take care] below
-  = do  { uniq <- getUniqueM
-        ; let name = mkSystemVarName uniq context
-              var = mkLocalIdOrCoVarWithInfo name expr_ty info
-        ; env'  <- completeNonRecX top_lvl env False var var expr
-        ; expr' <- simplVar env' var
-        ; return (env', expr') }
-        -- The simplVar is needed because we're constructing a new binding
-        --     a = rhs
-        -- And if rhs is of form (rhs1 |> co), then we might get
-        --     a1 = rhs1
-        --     a = a1 |> co
-        -- and now a's RHS is trivial and can be substituted out, and that
-        -- is what completeNonRecX will do
-        -- To put it another way, it's as if we'd simplified
-        --    let var = e in var
-  where
-    expr_ty = exprType expr
+  = return (emptyLetFloats, expr)
+
+  | otherwise
+  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr
+        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]
+          then return (floats, expr1)
+          else do
+        { uniq <- getUniqueM
+        ; let name = mkSystemVarName uniq occ_fs
+              var  = mkLocalIdOrCoVarWithInfo name expr_ty info
+
+        -- Now something very like completeBind,
+        -- but without the postInlineUnconditinoally part
+        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1
+        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
+
+        ; let final_id = addLetBndrInfo var arity is_bot unf
+              bind     = NonRec final_id expr2
+
+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}
+   where
+     expr_ty = exprType expr
 
 bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
 -- True iff we can have a binding of this expression at this level
@@ -732,10 +565,16 @@ bindingOk top_lvl expr expr_ty
   | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty
   | otherwise          = True
 
-{-
+{- Note [Trivial after prepareRhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we call makeTrival on (e |> co), the recursive use of prepareRhs
+may leave us with
+   { a1 = e }  and   (a1 |> co)
+Now the latter is trivial, so we don't want to let-bind it.
+
 Note [Cannot trivialise]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-Consider tih
+Consider:
    f :: Int -> Addr#
 
    foo :: Bar
@@ -761,7 +600,7 @@ See Note [CoreSyn top-level string literals] in CoreSyn.
 
 ************************************************************************
 *                                                                      *
-\subsection{Completing a lazy binding}
+          Completing a lazy binding
 *                                                                      *
 ************************************************************************
 
@@ -787,22 +626,21 @@ Nor does it do the atomic-argument thing
 
 completeBind :: SimplEnv
              -> TopLevelFlag            -- Flag stuck into unfolding
-             -> RecFlag                 -- Recursive binding?
-             -> Maybe SimplCont         -- Required only for join point
+             -> MaybeJoinCont           -- Required only for join point
              -> InId                    -- Old binder
              -> OutId -> OutExpr        -- New binder and RHS
-             -> SimplM SimplEnv
+             -> SimplM (SimplFloats, SimplEnv)
 -- completeBind may choose to do its work
 --      * by extending the substitution (e.g. let x = y in ...)
 --      * or by adding to the floats in the envt
 --
 -- Binder /can/ be a JoinId
 -- Precondition: rhs obeys the let/app invariant
-completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs
+completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
  | isCoVar old_bndr
  = case new_rhs of
-     Coercion co -> return (extendCvSubst env old_bndr co)
-     _           -> return (addNonRec env new_bndr new_rhs)
+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))
 
  | otherwise
  = ASSERT( isId new_bndr )
@@ -810,87 +648,61 @@ completeBind env top_lvl is_rec mb_cont old_bndr new_bndr new_rhs
             old_unf  = unfoldingInfo old_info
             occ_info = occInfo old_info
 
-        -- Do eta-expansion on the RHS of the binding
-        -- See Note [Eta-expanding at let bindings] in SimplUtils
-      ; (new_arity, final_rhs) <- if isJoinId new_bndr
-                                    then return (manifestArity new_rhs, new_rhs)
-                                         -- Note [Don't eta-expand join points]
-                                    else tryEtaExpandRhs env is_rec
-                                                         new_bndr new_rhs
+         -- Do eta-expansion on the RHS of the binding
+         -- See Note [Eta-expanding at let bindings] in SimplUtils
+      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)
+                                                          new_bndr new_rhs
 
         -- Simplify the unfolding
       ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr
-                                           final_rhs old_unf
+                                           final_rhs (idType new_bndr) old_unf
+
+      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding
 
-      ; dflags <- getDynFlags
-      ; if postInlineUnconditionally dflags env top_lvl new_bndr occ_info
-                                     final_rhs new_unfolding
+      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
 
-                        -- Inline and discard the binding
-        then do  { tick (PostInlineUnconditionally old_bndr)
-                 ; return (extendIdSubst env old_bndr
-                              (DoneEx final_rhs (isJoinId_maybe new_bndr))) }
+        then -- Inline and discard the binding
+             do  { tick (PostInlineUnconditionally old_bndr)
+                 ; return ( emptyFloats env
+                          , extendIdSubst env old_bndr $
+                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }
                 -- Use the substitution to make quite, quite sure that the
                 -- substitution will happen, since we are going to discard the binding
-        else
-   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
-
-              -- Unfolding info: Note [Setting the new unfolding]
-            info2 = info1 `setUnfoldingInfo` new_unfolding
-
-              -- Demand info: Note [Setting the demand info]
-              --
-              -- We also have to nuke demand info if for some reason
-              -- eta-expansion *reduces* the arity of the binding to less
-              -- than that of the strictness sig. This can happen: see Note [Arity decrease].
-            info3 | isEvaldUnfolding new_unfolding
-                    || (case strictnessInfo info2 of
-                          StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
-                  = zapDemandInfo info2 `orElse` info2
-                  | otherwise
-                  = info2
-
-              -- Zap call arity info. We have used it by now (via
-              -- `tryEtaExpandRhs`), and the simplifier can invalidate this
-              -- information, leading to broken code later (e.g. #13479)
-            info4 = zapCallArityInfo info3
-
-            final_id = new_bndr `setIdInfo` info4
-
-      ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
-        return (addNonRec env final_id final_rhs) } }
-                -- The addNonRec adds it to the in-scope set too
-
-------------------------------
-addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
--- Add a new binding to the environment, complete with its unfolding
--- but *do not* do postInlineUnconditionally, because we have already
--- processed some of the scope of the binding
--- We still want the unfolding though.  Consider
---      let
---            x = /\a. let y = ... in Just y
---      in body
--- Then we float the y-binding out (via abstractFloats and addPolyBind)
--- but 'x' may well then be inlined in 'body' in which case we'd like the
--- opportunity to inline 'y' too.
---
--- INVARIANT: the arity is correct on the incoming binders
 
-addPolyBind top_lvl env (NonRec poly_id rhs)
-  = do  { unfolding <- simplLetUnfolding env top_lvl Nothing poly_id rhs
-                                         noUnfolding
-                        -- Assumes that poly_id did not have an INLINE prag
-                        -- which is perhaps wrong.  ToDo: think about this
-        ; let final_id = setIdInfo poly_id $
-                         idInfo poly_id `setUnfoldingInfo` unfolding
+        else -- Keep the binding
+             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
+             return (mkFloatBind env (NonRec final_bndr final_rhs)) }
 
-        ; return (addNonRec env final_id rhs) }
+addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId
+addLetBndrInfo new_bndr new_arity is_bot new_unf
+  = new_bndr `setIdInfo` info5
+  where
+    info1 = idInfo new_bndr `setArityInfo` new_arity
+
+    -- Unfolding info: Note [Setting the new unfolding]
+    info2 = info1 `setUnfoldingInfo` new_unf
+
+    -- Demand info: Note [Setting the demand info]
+    -- We also have to nuke demand info if for some reason
+    -- eta-expansion *reduces* the arity of the binding to less
+    -- than that of the strictness sig. This can happen: see Note [Arity decrease].
+    info3 | isEvaldUnfolding new_unf
+            || (case strictnessInfo info2 of
+                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
+          = zapDemandInfo info2 `orElse` info2
+          | otherwise
+          = info2
+
+    -- Bottoming bindings: see Note [Bottoming bindings]
+    info4 | is_bot    = info3 `setStrictnessInfo`
+                        mkClosedStrictSig (replicate new_arity topDmd) exnRes
+          | otherwise = info3
+
+     -- Zap call arity info. We have used it by now (via
+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this
+     -- information, leading to broken code later (e.g. #13479)
+    info5 = zapCallArityInfo info4
 
-addPolyBind _ env bind@(Rec _)
-  = return (extendFloats env bind)
-        -- Hack: letrecs are more awkward, so we extend "by steam"
-        -- without adding unfoldings etc.  At worst this leads to
-        -- more simplifier iterations
 
 {- Note [Arity decrease]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -915,6 +727,26 @@ Here opInt has arity 1; but when we apply the rule its arity drops to 0.
 That's why Specialise goes to a little trouble to pin the right arity
 on specialised functions too.
 
+Note [Bottoming bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   let x = error "urk"
+   in ...(case x of <alts>)...
+or
+   let f = \x. error (x ++ "urk")
+   in ...(case f "foo" of <alts>)...
+
+Then we'd like to drop the dead <alts> immediately.  So it's good to
+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as
+possible.
+
+We use tryEtaExpandRhs on every binding, and it turns ou that the
+arity computation it performs (via CoreArity.findRhsArity) already
+does a simple bottoming-expression analysis.  So all we need to do
+is propagate that info to the binder's IdInfo.
+
+This showed up in Trac #12150; see comment:16.
+
 Note [Setting the demand info]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the unfolding is a value, the demand info may
@@ -931,44 +763,6 @@ After inlining f at some of its call sites the original binding may
 (for example) be no longer strictly demanded.
 The solution here is a bit ad hoc...
 
-Note [Don't eta-expand join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point
-stands well to gain from its outer binding's eta-expansion, and eta-expanding a
-join point is fraught with issues like how to deal with a cast:
-
-    let join $j1 :: IO ()
-             $j1 = ...
-             $j2 :: Int -> IO ()
-             $j2 n = if n > 0 then $j1
-                              else ...
-
-    =>
-
-    let join $j1 :: IO ()
-             $j1 = (\eta -> ...)
-                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
-                                 ~  IO ()
-             $j2 :: Int -> IO ()
-             $j2 n = (\eta -> if n > 0 then $j1
-                                       else ...)
-                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
-                                 ~  IO ()
-
-The cast here can't be pushed inside the lambda (since it's not casting to a
-function type), so the lambda has to stay, but it can't because it contains a
-reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
-than try and detect this situation (and whatever other situations crop up!), we
-don't bother; again, any surrounding eta-expansion will improve these join
-points anyway, since an outer cast can *always* be pushed inside. By the time
-CorePrep comes around, the code is very likely to look more like this:
-
-    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
-             $j1 = (...) eta
-             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
-             $j2 = if n > 0 then $j1
-                            else (...) eta
 
 ************************************************************************
 *                                                                      *
@@ -1034,17 +828,17 @@ simplExprC :: SimplEnv
         -- Simplify an expression, given a continuation
 simplExprC env expr cont
   = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $
-    do  { (env', expr') <- simplExprF (zapFloats env) expr cont
+    do  { (floats, expr') <- simplExprF env expr cont
         ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
           -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
           -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $
-          return (wrapFloats env' expr') }
+          return (wrapFloats floats expr') }
 
 --------------------------------------------------
 simplExprF :: SimplEnv
            -> InExpr     -- A term-valued expression, never (Type ty)
            -> SimplCont
-           -> SimplM (SimplEnv, OutExpr)
+           -> SimplM (SimplFloats, OutExpr)
 
 simplExprF env e cont
   = {- pprTrace "simplExprF" (vcat
@@ -1054,12 +848,11 @@ simplExprF env e cont
       , text "tvsubst =" <+> ppr (seTvSubst env)
       , text "idsubst =" <+> ppr (seIdSubst env)
       , text "cvsubst =" <+> ppr (seCvSubst env)
-      {- , ppr (seLetFloats env) -}
       ]) $ -}
     simplExprF1 env e cont
 
 simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-            -> SimplM (SimplEnv, OutExpr)
+            -> SimplM (SimplFloats, OutExpr)
 
 simplExprF1 _ (Type ty) _
   = pprPanic "simplExprF: type" (ppr ty)
@@ -1067,14 +860,14 @@ simplExprF1 _ (Type ty) _
     -- The (Type ty) case is handled separately by simplExpr
     -- and by the other callers of simplExprF
 
-simplExprF1 env (Var v)        cont = simplIdF env v cont
-simplExprF1 env (Lit lit)      cont = rebuild env (Lit lit) cont
-simplExprF1 env (Tick t expr)  cont = simplTick env t expr cont
-simplExprF1 env (Cast body co) cont = simplCast env body co cont
-simplExprF1 env (Coercion co)  cont = simplCoercionF env co cont
+simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont
+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont
+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont
+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont
+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont
 
 simplExprF1 env (App fun arg) cont
-  = case arg of
+  = {-#SCC "simplExprF1-App" #-} case arg of
       Type ty -> do { -- The argument type will (almost) certainly be used
                       -- in the output program, so just force it now.
                       -- See Note [Avoiding space leaks in OutType]
@@ -1094,7 +887,8 @@ simplExprF1 env (App fun arg) cont
                             , sc_dup = NoDup, sc_cont = cont }
 
 simplExprF1 env expr@(Lam {}) cont
-  = simplLam env zapped_bndrs body cont
+  = {-#SCC "simplExprF1-Lam" #-}
+    simplLam env zapped_bndrs body cont
         -- The main issue here is under-saturated lambdas
         --   (\x1. \x2. e) arg1
         -- Here x1 might have "occurs-once" occ-info, because occ-info
@@ -1116,28 +910,30 @@ simplExprF1 env expr@(Lam {}) cont
           | otherwise = zapLamIdInfo b
 
 simplExprF1 env (Case scrut bndr _ alts) cont
-  | sm_case_case (getMode env)
-  = simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
+  = {-#SCC "simplExprF1-Case" #-}
+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
                                  , sc_alts = alts
                                  , sc_env = env, sc_cont = cont })
-  | otherwise
-  = do { (env', scrut') <- simplExprF (zapFloats env) scrut $
-                           mkBoringStop (substTy env (idType bndr))
-       ; let scrut'' = wrapJoinFloats (seJoinFloats env') scrut'
-             env''   = env `addLetFloats` env'
-       ; rebuildCase env'' scrut'' bndr alts cont }
 
 simplExprF1 env (Let (Rec pairs) body) cont
-  = simplRecE env pairs body cont
+  | Just pairs' <- joinPointBindings_maybe pairs
+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont
+
+  | otherwise
+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont
 
 simplExprF1 env (Let (NonRec bndr rhs) body) cont
   | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)
-  = ASSERT( isTyVar bndr )
+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}
+    ASSERT( isTyVar bndr )
     do { ty' <- simplType env ty
        ; simplExprF (extendTvSubst env bndr ty') body cont }
 
+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont
+
   | otherwise
-  = simplNonRecE env bndr (rhs, env) ([], body) cont
+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont
 
 {- Note [Avoiding space leaks in OutType]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1213,15 +1009,16 @@ simplType env ty
 
 ---------------------------------
 simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
-               -> SimplM (SimplEnv, OutExpr)
+               -> SimplM (SimplFloats, OutExpr)
 simplCoercionF env co cont
   = do { co' <- simplCoercion env co
        ; rebuild env (Coercion co') cont }
 
 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
 simplCoercion env co
-  = let opt_co = optCoercion (getTCvSubst env) co
-    in seqCo opt_co `seq` return opt_co
+  = do { dflags <- getDynFlags
+       ; let opt_co = optCoercion dflags (getTCvSubst env) co
+       ; seqCo opt_co `seq` return opt_co }
 
 -----------------------------------
 -- | Push a TickIt context outwards past applications and cases, as
@@ -1229,7 +1026,7 @@ simplCoercion env co
 -- optimisations apply.
 
 simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
-          -> SimplM (SimplEnv, OutExpr)
+          -> SimplM (SimplFloats, OutExpr)
 simplTick env tickish expr cont
   -- A scoped tick turns into a continuation, so that we can spot
   -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
@@ -1256,8 +1053,8 @@ simplTick env tickish expr cont
   -- application context, allowing the normal case and application
   -- optimisations to fire.
   | tickish `tickishScopesLike` SoftScope
-  = do { (env', expr') <- simplExprF env expr cont
-       ; return (env', mkTick tickish expr')
+  = do { (floats, expr') <- simplExprF env expr cont
+       ; return (floats, mkTick tickish expr')
        }
 
   -- Push tick inside if the context looks like this will allow us to
@@ -1295,8 +1092,8 @@ simplTick env tickish expr cont
 
   no_floating_past_tick =
     do { let (inc,outc) = splitCont cont
-       ; (env1, expr1) <- simplExprF (zapFloats env) expr inc
-       ; let expr2    = wrapFloats env1 expr1
+       ; (floats, expr1) <- simplExprF env expr inc
+       ; let expr2    = wrapFloats floats expr1
              tickish' = simplTickish env tickish
        ; rebuild env (mkTick tickish' expr2) outc
        }
@@ -1378,27 +1175,28 @@ simplTick env tickish expr cont
 ************************************************************************
 -}
 
-rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
--- At this point the substitution in the SimplEnv should be irrelevant
--- only the in-scope set and floats should matter
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+-- At this point the substitution in the SimplEnv should be irrelevant;
+-- only the in-scope set matters
 rebuild env expr cont
   = case cont of
-      Stop {}          -> return (env, expr)
+      Stop {}          -> return (emptyFloats env, expr)
       TickIt t cont    -> rebuild env (mkTick t expr) cont
       CastIt co cont   -> rebuild env (mkCast expr co) cont
                        -- NB: mkCast implements the (Coercion co |> g) optimisation
 
       Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
-        -> rebuildCase (se `setFloats` env) expr bndr alts cont
+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
 
       StrictArg { sc_fun = fun, sc_cont = cont }
         -> rebuildCall env (fun `addValArgTo` expr) cont
       StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
                  , sc_env = se, sc_cont = cont }
-        -> do { env' <- simplNonRecX (se `setFloats` env) b expr
-                             -- expr satisfies let/app since it started life
-                             -- in a call to simplNonRecE
-              ; simplLam env' bs body cont }
+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
+                                  -- expr satisfies let/app since it started life
+                                  -- in a call to simplNonRecE
+              ; (floats2, expr') <- simplLam env' bs body cont
+              ; return (floats1 `addFloats` floats2, expr') }
 
       ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}
         -> rebuild env (App expr (Type ty)) cont
@@ -1416,54 +1214,94 @@ rebuild env expr cont
 ************************************************************************
 -}
 
+{- Note [Optimising reflexivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important (for compiler performance) to get rid of reflexivity as soon
+as it appears.  See Trac #11735, #14737, and #15019.
+
+In particular, we want to behave well on
+
+ *  e |> co1 |> co2
+    where the two happen to cancel out entirely. That is quite common;
+    e.g. a newtype wrapping and unwrapping cancel.
+
+
+ * (f |> co) @t1 @t2 ... @tn x1 .. xm
+   Here we wil use pushCoTyArg and pushCoValArg successively, which
+   build up NthCo stacks.  Silly to do that if co is reflexive.
+
+However, we don't want to call isReflexiveCo too much, because it uses
+type equality which is expensive on big types (Trac #14737 comment:7).
+
+A good compromise (determined experimentally) seems to be to call
+isReflexiveCo
+ * when composing casts, and
+ * at the end
+
+In investigating this I saw missed opportunities for on-the-fly
+coercion shrinkage. See Trac #15090.
+-}
+
+
 simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
-          -> SimplM (SimplEnv, OutExpr)
+          -> SimplM (SimplFloats, OutExpr)
 simplCast env body co0 cont0
-  = do  { co1   <- simplCoercion env co0
-        ; cont1 <- addCoerce co1 cont0
-        ; simplExprF env body cont1 }
+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}
+                   if isReflCo co1
+                   then return cont0  -- See Note [Optimising reflexivity]
+                   else addCoerce co1 cont0
+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
   where
-       addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
-       addCoerce co1 (CastIt co2 cont)
-         = addCoerce (mkTransCo co1 co2) cont
-
-       addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
-         | Just (arg_ty', co') <- pushCoTyArg co arg_ty
-         = do { tail' <- addCoerce co' tail
-              ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
-
-       addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
-                                , sc_dup = dup, sc_cont = tail })
-         | Just (co1, co2) <- pushCoValArg co
-         , Pair _ new_ty <- coercionKind co1
-         , not (isTypeLevPoly new_ty)  -- without this check, we get a lev-poly arg
-                                       -- See Note [Levity polymorphism invariants] in CoreSyn
-                                       -- test: typecheck/should_run/EtaExpandLevPoly
-         = do { tail' <- addCoerce co2 tail
-              ; if isReflCo co1
-                then return (cont { sc_cont = tail' })
-                     -- Avoid simplifying if possible;
-                     -- See Note [Avoiding exponential behaviour]
-                else do
-              { (dup', arg_se', arg') <- simplArg env dup arg_se arg
-                   -- When we build the ApplyTo we can't mix the OutCoercion
-                   -- 'co' with the InExpr 'arg', so we simplify
-                   -- to make it all consistent.  It's a bit messy.
-                   -- But it isn't a common case.
-                   -- Example of use: Trac #995
-              ; return (ApplyToVal { sc_arg  = mkCast arg' co1
-                                   , sc_env  = arg_se'
-                                   , sc_dup  = dup'
-                                   , sc_cont = tail' }) } }
-
-       addCoerce co cont
-         | isReflexiveCo co = return cont
-         | otherwise        = return (CastIt co cont)
-                -- It's worth checking isReflexiveCo.
-                -- For example, in the initial form of a worker
-                -- we may find  (coerce T (coerce S (\x.e))) y
-                -- and we'd like it to simplify to e[y/x] in one round
-                -- of simplification
+        -- If the first parameter is MRefl, then simplifying revealed a
+        -- reflexive coercion. Omit.
+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerceM MRefl   cont = return cont
+        addCoerceM (MCo co) cont = addCoerce co cont
+
+        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]
+          | isReflexiveCo co' = return cont
+          | otherwise         = addCoerce co' cont
+          where
+            co' = mkTransCo co1 co2
+
+        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+          = {-#SCC "addCoerce-pushCoTyArg" #-}
+            do { tail' <- addCoerceM m_co' tail
+               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+
+        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
+                                      , sc_dup = dup, sc_cont = tail })
+          | Just (co1, m_co2) <- pushCoValArg co
+          , Pair _ new_ty <- coercionKind co1
+          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg
+                                        -- See Note [Levity polymorphism invariants] in CoreSyn
+                                        -- test: typecheck/should_run/EtaExpandLevPoly
+          = {-#SCC "addCoerce-pushCoValArg" #-}
+            do { tail' <- addCoerceM m_co2 tail
+               ; if isReflCo co1
+                 then return (cont { sc_cont = tail' })
+                      -- Avoid simplifying if possible;
+                      -- See Note [Avoiding exponential behaviour]
+                 else do
+               { (dup', arg_se', arg') <- simplArg env dup arg_se arg
+                    -- When we build the ApplyTo we can't mix the OutCoercion
+                    -- 'co' with the InExpr 'arg', so we simplify
+                    -- to make it all consistent.  It's a bit messy.
+                    -- But it isn't a common case.
+                    -- Example of use: Trac #995
+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1
+                                    , sc_env  = arg_se'
+                                    , sc_dup  = dup'
+                                    , sc_cont = tail' }) } }
+
+        addCoerce co cont
+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge
+                                            -- difference in T12227, for some reason
+                                            -- See Note [Optimising reflexivity]
+          | otherwise        = return (CastIt co cont)
 
 simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
          -> SimplM (DupFlag, StaticEnv, OutExpr)
@@ -1471,7 +1309,7 @@ simplArg env dup_flag arg_env arg
   | isSimplified dup_flag
   = return (dup_flag, arg_env, arg)
   | otherwise
-  = do { arg' <- simplExpr (arg_env `setInScopeAndZapFloats` env) arg
+  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg
        ; return (Simplified, zapSubstEnv arg_env, arg') }
 
 {-
@@ -1480,27 +1318,13 @@ simplArg env dup_flag arg_env arg
 \subsection{Lambdas}
 *                                                                      *
 ************************************************************************
-
-Note [Zap unfolding when beta-reducing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Lambda-bound variables can have stable unfoldings, such as
-   $j = \x. \b{Unf=Just x}. e
-See Note [Case binders and join points] below; the unfolding for lets
-us optimise e better.  However when we beta-reduce it we want to
-revert to using the actual value, otherwise we can end up in the
-stupid situation of
-          let x = blah in
-          let b{Unf=Just x} = y
-          in ...b...
-Here it'd be far better to drop the unfolding and use the actual RHS.
 -}
 
 simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-         -> SimplM (SimplEnv, OutExpr)
+         -> SimplM (SimplFloats, OutExpr)
 
-simplLam env [] body cont = simplExprF env body cont
-
-        -- Beta reduction
+simplLam env [] body cont
+  = simplExprF env body cont
 
 simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
   = do { tick (BetaReduction bndr)
@@ -1511,8 +1335,9 @@ simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
   | isSimplified dup  -- Don't re-simplify if we've simplified it once
                       -- See Note [Avoiding exponential behaviour]
   = do  { tick (BetaReduction bndr)
-        ; env' <- simplNonRecX env zapped_bndr arg
-        ; simplLam env' bndrs body cont }
+        ; (floats1, env') <- simplNonRecX env zapped_bndr arg
+        ; (floats2, expr') <- simplLam env' bndrs body cont
+        ; return (floats1 `addFloats` floats2, expr') }
 
   | otherwise
   = do  { tick (BetaReduction bndr)
@@ -1522,7 +1347,7 @@ simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
       | isId bndr = zapStableUnfolding bndr
       | otherwise = bndr
 
-      -- discard a non-counting tick on a lambda.  This may change the
+      -- Discard a non-counting tick on a lambda.  This may change the
       -- cost attribution slightly (moving the allocation of the
       -- lambda elsewhere), but we don't care: optimisation changes
       -- cost attribution all the time.
@@ -1537,9 +1362,6 @@ simplLam env bndrs body cont
         ; new_lam <- mkLam env bndrs' body' cont
         ; rebuild env' new_lam cont }
 
-simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
-
 -------------
 simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- Used for lambda binders.  These sometimes have unfoldings added by
@@ -1551,7 +1373,8 @@ simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 simplLamBndr env bndr
   | isId bndr && isFragileUnfolding old_unf   -- Special case
   = do { (env1, bndr1) <- simplBinder env bndr
-       ; unf'          <- simplUnfolding env1 NotTopLevel Nothing bndr old_unf
+       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr
+                                               old_unf (idType bndr1)
        ; let bndr2 = bndr1 `setIdUnfolding` unf'
        ; return (modifyInScope env1 bndr2, bndr2) }
 
@@ -1560,18 +1383,21 @@ simplLamBndr env bndr
   where
     old_unf = idUnfolding bndr
 
+simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
+
 ------------------
 simplNonRecE :: SimplEnv
              -> InId                    -- The binder, always an Id
-                                        -- Can be a join point
+                                        -- Never a join point
              -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
              -> ([InBndr], InExpr)      -- Body of the let/lambda
                                         --      \xs.e
              -> SimplCont
-             -> SimplM (SimplEnv, OutExpr)
+             -> SimplM (SimplFloats, OutExpr)
 
 -- simplNonRecE is used for
---  * non-top-level non-recursive lets in expressions
+--  * non-top-level non-recursive non-join-point lets in expressions
 --  * beta reduction
 --
 -- simplNonRec env b (rhs, rhs_se) (bs, body) k
@@ -1590,74 +1416,276 @@ simplNonRecE :: SimplEnv
 --       the call to simplLam in simplExprF (Lam ...)
 
 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
-  = ASSERT( isId bndr )
-    do dflags <- getDynFlags
-       case () of
-         _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs
-           -> do { tick (PreInlineUnconditionally bndr)
-                 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
-                  simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
-
-           -- Deal with join points
-           | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
-           -> ASSERT( null bndrs )  -- Must be a let-binding;
-                                    -- join points are never lambda-bound
-              do { (env1, cont') <- prepareJoinCont env cont
-
-                   -- We push cont_dup into the join RHS and the body;
-                   -- and wrap cont_nodup around the whole thing
-                 ; let res_ty = contResultType cont'
-                 ; (env2, bndr1) <- simplNonRecJoinBndr env1 res_ty bndr'
-                 ; (env3, bndr2) <- addBndrRules env2 bndr' bndr1
-                 ; env4 <- simplJoinBind env3 NonRecursive cont'
-                                         bndr' bndr2 rhs' rhs_se
-                 ; simplExprF env4 body cont' }
-
-           -- Deal with strict bindings
-           | isStrictId bndr          -- Includes coercions
-           , sm_case_case (getMode env)
-           -> simplExprF (rhs_se `setFloats` env) rhs
-                         (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
-                                     , sc_env = env, sc_cont = cont, sc_dup = NoDup })
-
-           -- Deal with lazy bindings
-           | otherwise
-           -> ASSERT( not (isTyVar bndr) )
-              do { (env1, bndr1) <- simplNonRecBndr env bndr
-                 ; (env2, bndr2) <- addBndrRules env1 bndr bndr1
-                 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
-                 ; simplLam env3 bndrs body cont }
+  | ASSERT( isId bndr && not (isJoinId bndr) ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
+  = do { tick (PreInlineUnconditionally bndr)
+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+         simplLam env' bndrs body cont }
+
+  -- Deal with strict bindings
+  | isStrictId bndr          -- Includes coercions
+  , sm_case_case (getMode env)
+  = simplExprF (rhs_se `setInScopeFromE` env) rhs
+               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+  -- Deal with lazy bindings
+  | otherwise
+  = ASSERT( not (isTyVar bndr) )
+    do { (env1, bndr1) <- simplNonRecBndr env bndr
+       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing
+       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+       ; (floats2, expr') <- simplLam env3 bndrs body cont
+       ; return (floats1 `addFloats` floats2, expr') }
 
 ------------------
 simplRecE :: SimplEnv
           -> [(InId, InExpr)]
           -> InExpr
           -> SimplCont
-          -> SimplM (SimplEnv, OutExpr)
+          -> SimplM (SimplFloats, OutExpr)
 
 -- simplRecE is used for
 --  * non-top-level recursive lets in expressions
 simplRecE env pairs body cont
-  | Just pairs' <- joinPointBindings_maybe pairs
-  = do  { (env1, cont') <- prepareJoinCont env cont
-        ; let bndrs' = map fst pairs'
-              res_ty = contResultType cont
-        ; env2 <- simplRecJoinBndrs env1 res_ty bndrs'
-                -- NB: bndrs' don't have unfoldings or rules
-                -- We add them as we go down
-        ; env3 <- simplRecBind env2 NotTopLevel (Just cont') pairs'
-        ; simplExprF env3 body cont' }
-
-  | otherwise
   = do  { let bndrs = map fst pairs
         ; MASSERT(all (not . isJoinId) bndrs)
         ; env1 <- simplRecBndrs env bndrs
                 -- NB: bndrs' don't have unfoldings or rules
                 -- We add them as we go down
-        ; env2 <- simplRecBind env1 NotTopLevel Nothing pairs
-        ; simplExprF env2 body cont }
+        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs
+        ; (floats2, expr') <- simplExprF env2 body cont
+        ; return (floats1 `addFloats` floats2, expr') }
+
+{- Note [Avoiding exponential behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One way in which we can get exponential behaviour is if we simplify a
+big expression, and the re-simplify it -- and then this happens in a
+deeply-nested way.  So we must be jolly careful about re-simplifying
+an expression.  That is why completeNonRecX does not try
+preInlineUnconditionally.
+
+Example:
+  f BIG, where f has a RULE
+Then
+ * We simplify BIG before trying the rule; but the rule does not fire
+ * We inline f = \x. x True
+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)
+
+However, if BIG has /not/ already been simplified, we'd /like/ to
+simplify BIG True; maybe good things happen.  That is why
+
+* simplLam has
+    - a case for (isSimplified dup), which goes via simplNonRecX, and
+    - a case for the un-simplified case, which goes via simplNonRecE
+
+* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,
+  in at least two places
+    - In simplCast/addCoerce, where we check for isReflCo
+    - In rebuildCall we avoid simplifying arguments before we have to
+      (see Note [Trying rewrite rules])
+
+
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+   $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better.  However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+          let x = blah in
+          let b{Unf=Just x} = y
+          in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
+************************************************************************
+*                                                                      *
+                     Join points
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Rules and unfolding for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   simplExpr (join j x = rhs                         ) cont
+             (      {- RULE j (p:ps) = blah -}       )
+             (      {- StableUnfolding j = blah -}   )
+             (in blah                                )
+
+Then we will push 'cont' into the rhs of 'j'.  But we should *also* push
+'cont' into the RHS of
+  * Any RULEs for j, e.g. generated by SpecConstr
+  * Any stable unfolding for j, e.g. the result of an INLINE pragma
+
+Simplifying rules and stable-unfoldings happens a bit after
+simplifying the right-hand side, so we remember whether or not it
+is a join point, and what 'cont' is, in a value of type MaybeJoinCont
+
+Trac #13900 wsa caused by forgetting to push 'cont' into the RHS
+of a SpecConstr-generated RULE for a join point.
+-}
+
+type MaybeJoinCont = Maybe SimplCont
+  -- Nothing => Not a join point
+  -- Just k  => This is a join binding with continuation k
+  -- See Note [Rules and unfolding for join points]
+
+simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
+                     -> InExpr -> SimplCont
+                     -> SimplM (SimplFloats, OutExpr)
+simplNonRecJoinPoint env bndr rhs body cont
+  | ASSERT( isJoinId bndr ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
+  = do { tick (PreInlineUnconditionally bndr)
+       ; simplExprF env' body cont }
+
+   | otherwise
+   = wrapJoinCont env cont $ \ env cont ->
+     do { -- We push join_cont into the join RHS and the body;
+          -- and wrap wrap_cont around the whole thing
+        ; let res_ty = contResultType cont
+        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr
+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)
+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env
+        ; (floats2, body') <- simplExprF env3 body cont
+        ; return (floats1 `addFloats` floats2, body') }
+
+
+------------------
+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
+                  -> InExpr -> SimplCont
+                  -> SimplM (SimplFloats, OutExpr)
+simplRecJoinPoint env pairs body cont
+  = wrapJoinCont env cont $ \ env cont ->
+    do { let bndrs = map fst pairs
+             res_ty = contResultType cont
+       ; env1 <- simplRecJoinBndrs env res_ty bndrs
+               -- NB: bndrs' don't have unfoldings or rules
+               -- We add them as we go down
+       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs
+       ; (floats2, body') <- simplExprF env2 body cont
+       ; return (floats1 `addFloats` floats2, body') }
+
+--------------------
+wrapJoinCont :: SimplEnv -> SimplCont
+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+             -> SimplM (SimplFloats, OutExpr)
+-- Deal with making the continuation duplicable if necessary,
+-- and with the no-case-of-case situation.
+wrapJoinCont env cont thing_inside
+  | contIsStop cont        -- Common case; no need for fancy footwork
+  = thing_inside env cont
+
+  | not (sm_case_case (getMode env))
+    -- See Note [Join points wih -fno-case-of-case]
+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
+       ; return (floats2 `addFloats` floats3, expr3) }
+
+  | otherwise
+    -- Normal case; see Note [Join points and case-of-case]
+  = do { (floats1, cont')  <- mkDupableCont env cont
+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+       ; return (floats1 `addFloats` floats2, result) }
+
+
+--------------------
+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont
+-- Drop outer context from join point invocation (jump)
+-- See Note [Join points and case-of-case]
+
+trimJoinCont _ Nothing cont
+  = cont -- Not a jump
+trimJoinCont var (Just arity) cont
+  = trim arity cont
+  where
+    trim 0 cont@(Stop {})
+      = cont
+    trim 0 cont
+      = mkBoringStop (contResultType cont)
+    trim n cont@(ApplyToVal { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k }
+    trim n cont@(ApplyToTy { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!
+    trim _ cont
+      = pprPanic "completeCall" $ ppr var $$ ppr cont
+
+
+{- Note [Join points and case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we perform the case-of-case transform (or otherwise push continuations
+inward), we want to treat join points specially. Since they're always
+tail-called and we want to maintain this invariant, we can do this (for any
+evaluation context E):
+
+  E[join j = e
+    in case ... of
+         A -> jump j 1
+         B -> jump j 2
+         C -> f 3]
+
+    -->
+
+  join j = E[e]
+  in case ... of
+       A -> jump j 1
+       B -> jump j 2
+       C -> E[f 3]
+
+As is evident from the example, there are two components to this behavior:
+
+  1. When entering the RHS of a join point, copy the context inside.
+  2. When a join point is invoked, discard the outer context.
+
+We need to be very careful here to remain consistent---neither part is
+optional!
+
+We need do make the continuation E duplicable (since we are duplicating it)
+with mkDuableCont.
+
+
+Note [Join points wih -fno-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose case-of-case is switched off, and we are simplifying
+
+    case (join j x = <j-rhs> in
+          case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+Usually, we'd push the outer continuation (case . of <outer-alts>) into
+both the RHS and the body of the join point j.  But since we aren't doing
+case-of-case we may then end up with this totally bogus result
+
+    join x = case <j-rhs> of <outer-alts> in
+    case (case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+This would be OK in the language of the paper, but not in GHC: j is no longer
+a join point.  We can only do the "push contination into the RHS of the
+join point j" if we also push the contination right down to the /jumps/ to
+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to
+
+    join x = case <j-rhs> of <outer-alts> in
+    case y of
+      A -> j 1
+      B -> j 2
+      C -> case e of <outer-alts>
+
+which is great.
+
+Bottom line: if case-of-case is off, we must stop pushing the continuation
+inwards altogether at any join point.  Instead simplify the (join ... in ...)
+with a Stop continuation, and wrap the original continuation around the
+outside.  Surprisingly tricky!
+
 
-{-
 ************************************************************************
 *                                                                      *
                      Variables
@@ -1676,67 +1704,53 @@ simplVar env var
         DoneId var1          -> return (Var var1)
         DoneEx e _           -> return e
 
-simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
 simplIdF env var cont
   = case substId env var of
-        ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
-                                  -- Don't trim; haven't already simplified e,
-                                  -- so the cont is not embodied in e
-
-        DoneId var1      -> completeCall env var1 (trim_cont (isJoinId_maybe var1))
-        DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trim_cont mb_join)
-                -- Note [zapSubstEnv]
-                -- The template is already simplified, so don't re-substitute.
-                -- This is VITAL.  Consider
-                --      let x = e in
-                --      let y = \z -> ...x... in
-                --      \ x -> ...y...
-                -- We'll clone the inner \x, adding x->x' in the id_subst
-                -- Then when we inline y, we must *not* replace x by x' in
-                -- the inlined copy!!
-  where
-    trim_cont (Just arity) = trim arity cont
-    trim_cont Nothing      = cont
-
-    -- Drop outer context from join point invocation
-    -- Note [Case-of-case and join points]
-    trim 0 cont@(Stop {})
-      = cont
-    trim 0 cont
-      = mkBoringStop (contResultType cont)
-    trim n cont@(ApplyToVal { sc_cont = k })
-      = cont { sc_cont = trim (n-1) k }
-    trim n cont@(ApplyToTy { sc_cont = k })
-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!
-    trim _ cont
-      = pprPanic "completeCall" $ ppr var $$ ppr cont
+      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+                                -- Don't trim; haven't already simplified e,
+                                -- so the cont is not embodied in e
+
+      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)
+
+      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)
+              -- Note [zapSubstEnv]
+              -- The template is already simplified, so don't re-substitute.
+              -- This is VITAL.  Consider
+              --      let x = e in
+              --      let y = \z -> ...x... in
+              --      \ x -> ...y...
+              -- We'll clone the inner \x, adding x->x' in the id_subst
+              -- Then when we inline y, we must *not* replace x by x' in
+              -- the inlined copy!!
 
 ---------------------------------------------------------
 --      Dealing with a call site
 
-completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
 completeCall env var cont
-  = do  {   ------------- Try inlining ----------------
-          dflags <- getDynFlags
-        ; let  (lone_variable, arg_infos, call_cont) = contArgs cont
-               n_val_args = length arg_infos
-               interesting_cont = interestingCallContext call_cont
-               unfolding    = activeUnfolding env var
-               maybe_inline = callSiteInline dflags var unfolding
-                                             lone_variable arg_infos interesting_cont
-        ; case maybe_inline of
-            Just expr      -- There is an inlining!
-              ->  do { checkedTick (UnfoldingDone var)
-                     ; dump_inline dflags expr cont
-                     ; simplExprF (zapSubstEnv env) expr cont }
-
-            ; Nothing -> do { rule_base <- getSimplRules
-                            ; let info = mkArgInfo var (getRules rule_base var)
-                                                   n_val_args call_cont
-                            ; rebuildCall env info cont }
-    }
+  | Just expr <- callSiteInline dflags var active_unf
+                                lone_variable arg_infos interesting_cont
+  -- Inline the variable's RHS
+  = do { checkedTick (UnfoldingDone var)
+       ; dump_inline expr cont
+       ; simplExprF (zapSubstEnv env) expr cont }
+
+  | otherwise
+  -- Don't inline; instead rebuild the call
+  = do { rule_base <- getSimplRules
+       ; let info = mkArgInfo env var (getRules rule_base var)
+                              n_val_args call_cont
+       ; rebuildCall env info cont }
+
   where
-    dump_inline dflags unfolding cont
+    dflags = seDynFlags env
+    (lone_variable, arg_infos, call_cont) = contArgs cont
+    n_val_args       = length arg_infos
+    interesting_cont = interestingCallContext env call_cont
+    active_unf       = activeUnfolding (getMode env) var
+
+    dump_inline unfolding cont
       | not (dopt Opt_D_dump_inlinings dflags) = return ()
       | not (dopt Opt_D_verbose_core2core dflags)
       = when (isExternalName (idName var)) $
@@ -1751,7 +1765,7 @@ completeCall env var cont
 rebuildCall :: SimplEnv
             -> ArgInfo
             -> SimplCont
-            -> SimplM (SimplEnv, OutExpr)
+            -> SimplM (SimplFloats, OutExpr)
 -- We decided not to inline, so
 --    - simplify the arguments
 --    - try rewrite rules
@@ -1773,7 +1787,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
                                  -- continuation to discard, else we do it
                                  -- again and again!
   = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]
-    return (env, castBottomExpr res cont_ty)
+    return (emptyFloats env, castBottomExpr res cont_ty)
   where
     res     = argInfoExpr fun rev_args
     cont_ty = contResultType cont
@@ -1812,10 +1826,10 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
   = rebuildCall env (addValArgTo info' arg) cont
 
-  | str                 -- Strict argument
+  | str         -- Strict argument
   , sm_case_case (getMode env)
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
-    simplExprF (arg_se `setFloats` env) arg
+    simplExprF (arg_se `setInScopeFromE` env) arg
                (StrictArg { sc_fun = info', sc_cci = cci_strict
                           , sc_dup = Simplified, sc_cont = cont })
                 -- Note [Shadowing]
@@ -1825,7 +1839,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
         -- There is no benefit (unlike in a let-binding), and we'd
         -- have to be very careful about bogus strictness through
         -- floating a demanded let.
-  = do  { arg' <- simplExprC (arg_se `setInScopeAndZapFloats` env) arg
+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
                              (mkLazyArgStop arg_ty cci_lazy)
         ; rebuildCall env (addValArgTo info' arg') cont }
   where
@@ -1936,13 +1950,13 @@ tryRules :: SimplEnv -> [CoreRule]
 tryRules env rules fn args call_cont
   | null rules
   = return Nothing
+
 {- Disabled until we fix #8326
   | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
   , [_type_arg, val_arg] <- args
   , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
   , isDeadBinder bndr
-  = do { dflags <- getDynFlags
-       ; let enum_to_tag :: CoreAlt -> CoreAlt
+  = do { let enum_to_tag :: CoreAlt -> CoreAlt
                 -- Takes   K -> e  into   tagK# -> e
                 -- where tagK# is the tag of constructor K
              enum_to_tag (DataAlt con, [], rhs)
@@ -1957,35 +1971,39 @@ tryRules env rules fn args call_cont
                  -- The binder is dead, but should have the right type
       ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
 -}
-  | otherwise
-  = do { dflags <- getDynFlags
-       ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
-                         fn (argInfoAppArgs args) rules of {
-           Nothing ->
-             do { nodump dflags  -- This ensures that an empty file is written
-                ; return Nothing } ;  -- No rule matches
-           Just (rule, rule_rhs) ->
-             do { checkedTick (RuleFired (ruleName rule))
-                ; let cont' = pushSimplifiedArgs zapped_env
-                                                 (drop (ruleArity rule) args)
-                                                 call_cont
-                              -- (ruleArity rule) says how
-                              -- many args the rule consumed
-
-                      occ_anald_rhs = occurAnalyseExpr rule_rhs
-                          -- See Note [Occurrence-analyse after rule firing]
-                ; dump dflags rule rule_rhs
-                ; return (Just (zapped_env, occ_anald_rhs, cont')) }}}
-                     -- The occ_anald_rhs and cont' are all Out things
-                     -- hence zapping the environment
+
+  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)
+                                        (activeRule (getMode env)) fn
+                                        (argInfoAppArgs args) rules
+  -- Fire a rule for the function
+  = do { checkedTick (RuleFired (ruleName rule))
+       ; let cont' = pushSimplifiedArgs zapped_env
+                                        (drop (ruleArity rule) args)
+                                        call_cont
+                     -- (ruleArity rule) says how
+                     -- many args the rule consumed
+
+             occ_anald_rhs = occurAnalyseExpr rule_rhs
+                 -- See Note [Occurrence-analyse after rule firing]
+       ; dump rule rule_rhs
+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }
+            -- The occ_anald_rhs and cont' are all Out things
+            -- hence zapping the environment
+
+  | otherwise  -- No rule fires
+  = do { nodump  -- This ensures that an empty file is written
+       ; return Nothing }
+
   where
+    dflags     = seDynFlags env
     zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]
 
-    printRuleModule rule =
-      parens
-        (maybe (text "BUILTIN") (pprModuleName . moduleName) (ruleModule rule))
+    printRuleModule rule
+      = parens (maybe (text "BUILTIN")
+                      (pprModuleName . moduleName)
+                      (ruleModule rule))
 
-    dump dflags rule rule_rhs
+    dump rule rule_rhs
       | dopt Opt_D_dump_rule_rewrites dflags
       = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
           [ text "Rule:" <+> ftext (ruleName rule)
@@ -2002,7 +2020,7 @@ tryRules env rules fn args call_cont
       | otherwise
       = return ()
 
-    nodump dflags
+    nodump
       | dopt Opt_D_dump_rule_rewrites dflags
       = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty
 
@@ -2195,49 +2213,62 @@ to just
 This particular example shows up in default methods for
 comparison operations (e.g. in (>=) for Int.Int32)
 
-Note [Case elimination: lifted case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If a case over a lifted type has a single alternative, and is being used
-as a strict 'let' (all isDeadBinder bndrs), we may want to do this
-transformation:
+Note [Case to let transformation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a case over a lifted type has a single alternative, and is being
+used as a strict 'let' (all isDeadBinder bndrs), we may want to do
+this transformation:
 
     case e of r       ===>   let r = e in ...r...
       _ -> ...r...
 
-        (a) 'e' is already evaluated (it may so if e is a variable)
-            Specifically we check (exprIsHNF e).  In this case
-            we can just allocate the WHNF directly with a let.
-or
-        (b) 'x' is not used at all and e is ok-for-speculation
-             The ok-for-spec bit checks that we don't lose any
-             exceptions or divergence.
+We treat the unlifted and lifted cases separately:
+
+* Unlifted case: 'e' satisfies exprOkForSpeculation
+  (ok-for-spec is needed to satisfy the let/app invariant).
+  This turns     case a +# b of r -> ...r...
+  into           let r = a +# b in ...r...
+  and thence     .....(a +# b)....
+
+  However, if we have
+      case indexArray# a i of r -> ...r...
+  we might like to do the same, and inline the (indexArray# a i).
+  But indexArray# is not okForSpeculation, so we don't build a let
+  in rebuildCase (lest it get floated *out*), so the inlining doesn't
+  happen either.  Annoying.
+
+* Lifted case: we need to be sure that the expression is already
+  evaluated (exprIsHNF).  If it's not already evaluated
+      - we risk losing exceptions, divergence or
+        user-specified thunk-forcing
+      - even if 'e' is guaranteed to converge, we don't want to
+        create a thunk (call by need) instead of evaluating it
+        right away (call by value)
+
+  However, we can turn the case into a /strict/ let if the 'r' is
+  used strictly in the body.  Then we won't lose divergence; and
+  we won't build a thunk because the let is strict.
+  See also Note [Case-to-let for strictly-used binders]
+
+  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
+  We want to turn
+     case (absentError "foo") of r -> ...MkT r...
+  into
+     let r = absentError "foo" in ...MkT r...
+
+
+Note [Case-to-let for strictly-used binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have this:
+   case <scrut> of r { _ -> ..r.. }
 
-             NB: it'd be *sound* to switch from case to let if the
-             scrutinee was not yet WHNF but was guaranteed to
-             converge; but sticking with case means we won't build a
-             thunk
+where 'r' is used strictly in (..r..), we can safely transform to
+   let r = <scrut> in ...r...
 
-or
-        (c) 'x' is used strictly in the body, and 'e' is a variable
-            Then we can just substitute 'e' for 'x' in the body.
-            See Note [Eliminating redundant seqs]
-
-For (b), the "not used at all" test is important.  Consider
-   case (case a ># b of { True -> (p,q); False -> (q,p) }) of
-     r -> blah
-The scrutinee is ok-for-speculation (it looks inside cases), but we do
-not want to transform to
-   let r = case a ># b of { True -> (p,q); False -> (q,p) }
-   in blah
-because that builds an unnecessary thunk.
-
-Note [Eliminating redundant seqs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have this:
-   case x of r { _ -> ..r.. }
-where 'r' is used strictly in (..r..), the case is effectively a 'seq'
-on 'x', but since 'r' is used strictly anyway, we can safely transform to
-   (...x...)
+This is a Good Thing, because 'r' might be dead (if the body just
+calls error), or might be used just once (in which case it can be
+inlined); or we might be able to float the let-binding up or down.
+E.g. Trac #15631 has an example.
 
 Note that this can change the error behaviour.  For example, we might
 transform
@@ -2253,7 +2284,24 @@ transformation bit us in practice.
 
 See also Note [Empty case alternatives] in CoreSyn.
 
-Just for reference, the original code (added Jan 13) looked like this:
+Historical notes
+
+There have been various earlier versions of this patch:
+
+* By Sept 18 the code looked like this:
+     || scrut_is_demanded_var scrut
+
+    scrut_is_demanded_var :: CoreExpr -> Bool
+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
+    scrut_is_demanded_var _          = False
+
+  This only fired if the scrutinee was a /variable/, which seems
+  an unnecessary restriction. So in Trac #15631 I relaxed it to allow
+  arbitrary scrutinees.  Less code, less to explain -- but the change
+  had 0.00% effect on nofib.
+
+* Previously, in Jan 13 the code looked like this:
      || case_bndr_evald_next rhs
 
     case_bndr_evald_next :: CoreExpr -> Bool
@@ -2264,25 +2312,8 @@ Just for reference, the original code (added Jan 13) looked like this:
     case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
     case_bndr_evald_next _               = False
 
-(This came up when fixing Trac #7542. See also Note [Eta reduction of
-an eval'd function] in CoreUtils.)
-
-
-Note [Case elimination: unlifted case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   case a +# b of r -> ...r...
-Then we do case-elimination (to make a let) followed by inlining,
-to get
-        .....(a +# b)....
-If we have
-   case indexArray# a i of r -> ...r...
-we might like to do the same, and inline the (indexArray# a i).
-But indexArray# is not okForSpeculation, so we don't build a let
-in rebuildCase (lest it get floated *out*), so the inlining doesn't
-happen either.
-
-This really isn't a big deal I think. The let can be
+  This patch was part of fixing Trac #7542. See also
+  Note [Eta reduction of an eval'd function] in CoreUtils.)
 
 
 Further notes about case elimination
@@ -2334,7 +2365,7 @@ rebuildCase, reallyRebuildCase
    -> InId             -- Case binder
    -> [InAlt]          -- Alternatives (inceasing order)
    -> SimplCont
-   -> SimplM (SimplEnv, OutExpr)
+   -> SimplM (SimplFloats, OutExpr)
 
 --------------------------------------------------
 --      1. Eliminate the case if there's a known constructor
@@ -2361,10 +2392,11 @@ rebuildCase env scrut case_bndr alts cont
         }
   where
     simple_rhs bs rhs = ASSERT( null bs )
-                        do { env' <- simplNonRecX env case_bndr scrut
+                        do { (floats1, env') <- simplNonRecX env case_bndr scrut
                                -- scrut is a constructor application,
                                -- hence satisfies let/app invariant
-                           ; simplExprF env' rhs cont }
+                           ; (floats2, expr') <- simplExprF env' rhs cont
+                           ; return (floats1 `addFloats` floats2, expr') }
 
 
 --------------------------------------------------
@@ -2392,14 +2424,13 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   --      a) it binds only the case-binder
   --      b) unlifted case: the scrutinee is ok-for-speculation
   --           lifted case: the scrutinee is in HNF (or will later be demanded)
+  -- See Note [Case to let transformation]
   | all_dead_bndrs
-  , if is_unlifted
-    then exprOkForSpeculation scrut  -- See Note [Case elimination: unlifted case]
-    else exprIsHNF scrut             -- See Note [Case elimination: lifted case]
-      || scrut_is_demanded_var scrut
+  , doCaseToLet scrut case_bndr
   = do { tick (CaseElim case_bndr)
-       ; env' <- simplNonRecX env case_bndr scrut
-       ; simplExprF env' rhs cont }
+       ; (floats1, env') <- simplNonRecX env case_bndr scrut
+       ; (floats2, expr') <- simplExprF env' rhs cont
+       ; return (floats1 `addFloats` floats2, expr') }
 
   -- 2c. Try the seq rules if
   --     a) it binds only the case binder
@@ -2411,42 +2442,45 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
            Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
            Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }
   where
-    is_unlifted        = isUnliftedType (idType case_bndr)
-    all_dead_bndrs     = all isDeadBinder bndrs       -- bndrs are [InId]
-    is_plain_seq       = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
-
-    scrut_is_demanded_var :: CoreExpr -> Bool
-            -- See Note [Eliminating redundant seqs]
-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
-    scrut_is_demanded_var _          = False
-
+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
 
 rebuildCase env scrut case_bndr alts cont
   = reallyRebuildCase env scrut case_bndr alts cont
 
+
+doCaseToLet :: OutExpr          -- Scrutinee
+            -> InId             -- Case binder
+            -> Bool
+-- The situation is         case scrut of b { DEFAULT -> body }
+-- Can we transform thus?   let { b = scrut } in body
+doCaseToLet scrut case_bndr
+  | isTyCoVar case_bndr    -- Respect CoreSyn
+  = isTyCoArg scrut        -- Note [CoreSyn type and coercion invariant]
+
+  | isUnliftedType (idType case_bndr)
+  = exprOkForSpeculation scrut
+
+  | otherwise  -- Scrut has a lifted type
+  = exprIsHNF scrut
+    || isStrictDmd (idDemandInfo case_bndr)
+    -- See Note [Case-to-let for strictly-used binders]
+
 --------------------------------------------------
 --      3. Catch-all case
 --------------------------------------------------
 
 reallyRebuildCase env scrut case_bndr alts cont
-  = do  {       -- Prepare the continuation;
-                -- The new subst_env is in place
-          (env, alt_cont, wrap_cont) <- prepareCaseCont env alts cont
-
-        -- Simplify the alternatives
-        ; (scrut', case_bndr', alts') <- simplAlts env scrut case_bndr alts alt_cont
+  | not (sm_case_case (getMode env))
+  = do { case_expr <- simplAlts env scrut case_bndr alts
+                                (mkBoringStop (contHoleType cont))
+       ; rebuild env case_expr cont }
 
-        ; dflags <- getDynFlags
-        ; let alts_ty' = contResultType alt_cont
-        -- See Note [Avoiding space leaks in OutType]
-        ; case_expr <- seqType alts_ty' `seq`
-                       mkCase dflags scrut' case_bndr' alts_ty' alts'
-
-        -- Notice that rebuild gets the in-scope set from env', not alt_env
-        -- (which in any case is only build in simplAlts)
-        -- The case binder *not* scope over the whole returned case-expression
-        ; rebuild env case_expr wrap_cont }
+  | otherwise
+  = do { (floats, cont') <- mkDupableCaseCont env alts cont
+       ; case_expr <- simplAlts (env `setInScopeFromF` floats)
+                                scrut case_bndr alts cont'
+       ; return (floats, case_expr) }
 
 {-
 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
@@ -2528,18 +2562,16 @@ robust here.  (Otherwise, there's a danger that we'll simply drop the
 -}
 
 simplAlts :: SimplEnv
-          -> OutExpr
-          -> InId                       -- Case binder
-          -> [InAlt]                    -- Non-empty
+          -> OutExpr         -- Scrutinee
+          -> InId            -- Case binder
+          -> [InAlt]         -- Non-empty
           -> SimplCont
-          -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
--- Like simplExpr, this just returns the simplified alternatives;
--- it does not return an environment
--- The returned alternatives can be empty, none are possible
-
-simplAlts env scrut case_bndr alts cont'
-  = do  { let env0 = zapFloats env
+          -> SimplM OutExpr  -- Returns the complete simplified case expression
 
+simplAlts env0 scrut case_bndr alts cont'
+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr
+                                      , text "cont':" <+> ppr cont'
+                                      , text "in_scope" <+> ppr (seInScope env0) ])
         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
         ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
               env2       = modifyInScope env1 case_bndr2
@@ -2555,7 +2587,11 @@ simplAlts env scrut case_bndr alts cont'
 
         ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
         ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
-          return (scrut', case_bndr', alts') }
+
+        ; let alts_ty' = contResultType cont'
+        -- See Note [Avoiding space leaks in OutType]
+        ; seqType alts_ty' `seq`
+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }
 
 
 ------------------------------------
@@ -2599,11 +2635,8 @@ simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
         ; return (LitAlt lit, [], rhs') }
 
 simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
-  = do  {       -- Deal with the pattern-bound variables
-                -- Mark the ones that are in ! positions in the
-                -- data constructor as certainly-evaluated.
-                -- NB: simplLamBinders preserves this eval info
-        ; let vs_with_evals = add_evals (dataConRepStrictness con)
+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]
+          let vs_with_evals = addEvals scrut' con vs
         ; (env', vs') <- simplLamBndrs env vs_with_evals
 
                 -- Bind the case-binder to (con args)
@@ -2614,53 +2647,92 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
         ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
         ; rhs' <- simplExprC env'' rhs cont'
         ; return (DataAlt con, vs', rhs') }
-  where
-        -- add_evals records the evaluated-ness of the bound variables of
-        -- a case pattern.  This is *important*.  Consider
-        --      data T = T !Int !Int
-        --
-        --      case x of { T a b -> T (a+1) b }
-        --
-        -- We really must record that b is already evaluated so that we don't
-        -- go and re-evaluate it when constructing the result.
-        -- See Note [Data-con worker strictness] in MkId.hs
-    add_evals the_strs
-        = go vs the_strs
+
+{- Note [Adding evaluatedness info to pattern-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+addEvals records the evaluated-ness of the bound variables of
+a case pattern.  This is *important*.  Consider
+
+     data T = T !Int !Int
+
+     case x of { T a b -> T (a+1) b }
+
+We really must record that b is already evaluated so that we don't
+go and re-evaluate it when constructing the result.
+See Note [Data-con worker strictness] in MkId.hs
+
+NB: simplLamBinders preserves this eval info
+
+In addition to handling data constructor fields with !s, addEvals
+also records the fact that the result of seq# is always in WHNF.
+See Note [seq# magic] in PrelRules.  Example (Trac #15226):
+
+  case seq# v s of
+    (# s', v' #) -> E
+
+we want the compiler to be aware that v' is in WHNF in E.
+
+Open problem: we don't record that v itself is in WHNF (and we can't
+do it here).  The right thing is to do some kind of binder-swap;
+see Trac #15226 for discussion.
+-}
+
+addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
+-- See Note [Adding evaluatedness info to pattern-bound variables]
+addEvals scrut con vs
+  -- Deal with seq# applications
+  | Just scr <- scrut
+  , isUnboxedTupleCon con
+  , [s,x] <- vs
+    -- Use stripNArgs rather than collectArgsTicks to avoid building
+    -- a list of arguments only to throw it away immediately.
+  , Just (Var f) <- stripNArgs 4 scr
+  , Just SeqOp <- isPrimOpId_maybe f
+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x
+  = [s, x']
+
+  -- Deal with banged datacon fields
+addEvals _scrut con vs = go vs the_strs
+    where
+      the_strs = dataConRepStrictness con
+
+      go [] [] = []
+      go (v:vs') strs | isTyVar v = v : go vs' strs
+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs
+      go _ _ = pprPanic "Simplify.addEvals"
+                (ppr con $$
+                 ppr vs  $$
+                 ppr_with_length (map strdisp the_strs) $$
+                 ppr_with_length (dataConRepArgTys con) $$
+                 ppr_with_length (dataConRepStrictness con))
         where
-          go [] [] = []
-          go (v:vs') strs | isTyVar v = v : go vs' strs
-          go (v:vs') (str:strs) = zap str v : go vs' strs
-          go _ _ = pprPanic "cat_evals"
-                    (ppr con $$
-                     ppr vs  $$
-                     ppr_with_length the_strs $$
-                     ppr_with_length (dataConRepArgTys con) $$
-                     ppr_with_length (dataConRepStrictness con))
-            where
-              ppr_with_length list
-                = ppr list <+> parens (text "length =" <+> ppr (length list))
-                                    -- NB: If this panic triggers, note that
-                                    -- NoStrictnessMark doesn't print!
-
-          zap str v = setCaseBndrEvald str $ -- Add eval'dness info
-                      zapIdOccInfo v         -- And kill occ info;
-                                             -- see Note [Case alternative occ info]
+          ppr_with_length list
+            = ppr list <+> parens (text "length =" <+> ppr (length list))
+          strdisp MarkedStrict = "MarkedStrict"
+          strdisp NotMarkedStrict = "NotMarkedStrict"
+
+zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id
+zapIdOccInfoAndSetEvald str v =
+  setCaseBndrEvald str $ -- Add eval'dness info
+  zapIdOccInfo v         -- And kill occ info;
+                         -- see Note [Case alternative occ info]
 
 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
 addAltUnfoldings env scrut case_bndr con_app
-  = do { dflags <- getDynFlags
-       ; let con_app_unf = mkSimpleUnfolding dflags con_app
+  = do { let con_app_unf = mk_simple_unf con_app
              env1 = addBinderUnfolding env case_bndr con_app_unf
 
              -- See Note [Add unfolding for scrutinee]
              env2 = case scrut of
                       Just (Var v)           -> addBinderUnfolding env1 v con_app_unf
                       Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
-                                                mkSimpleUnfolding dflags (Cast con_app (mkSymCo co))
+                                                mk_simple_unf (Cast con_app (mkSymCo co))
                       _                      -> env1
 
        ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
        ; return env2 }
+  where
+    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)
 
 addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
 addBinderUnfolding env bndr unf
@@ -2700,7 +2772,7 @@ Note [Add unfolding for scrutinee]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general it's unlikely that a variable scrutinee will appear
 in the case alternatives   case x of { ...x unlikely to appear... }
-because the binder-swap in OccAnal has got rid of all such occcurrences
+because the binder-swap in OccAnal has got rid of all such occurrences
 See Note [Binder swap] in OccAnal.
 
 BUT it is still VERY IMPORTANT to add a suitable unfolding for a
@@ -2756,17 +2828,18 @@ knownCon :: SimplEnv
          -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
          -> InId -> [InBndr] -> InExpr          -- The alternative
          -> SimplCont
-         -> SimplM (SimplEnv, OutExpr)
+         -> SimplM (SimplFloats, OutExpr)
 
 knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
-  = do  { env'  <- bind_args env bs dc_args
-        ; env'' <- bind_case_bndr env'
-        ; simplExprF env'' rhs cont }
+  = do  { (floats1, env1)  <- bind_args env bs dc_args
+        ; (floats2, env2) <- bind_case_bndr env1
+        ; (floats3, expr') <- simplExprF env2 rhs cont
+        ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
   where
     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
 
                   -- Ugh!
-    bind_args env' [] _  = return env'
+    bind_args env' [] _  = return (emptyFloats env', env')
 
     bind_args env' (b:bs') (Type ty : args)
       = ASSERT( isTyVar b )
@@ -2784,8 +2857,9 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
              -- it via postInlineUnconditionally.
              -- Nevertheless we must keep it if the case-binder is alive,
              -- because it may be used in the con_app.  See Note [knownCon occ info]
-           ; env'' <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant
-           ; bind_args env'' bs' args }
+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant
+           ; (floats2, env3)  <- bind_args env2 bs' args
+           ; return (floats1 `addFloats` floats2, env3) }
 
     bind_args _ _ _ =
       pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
@@ -2799,8 +2873,9 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
        -- about duplicating the arg redexes; in that case, make
        -- a new con-app from the args
     bind_case_bndr env
-      | isDeadBinder bndr   = return env
-      | exprIsTrivial scrut = return (extendIdSubst env bndr (DoneEx scrut Nothing))
+      | isDeadBinder bndr   = return (emptyFloats env, env)
+      | exprIsTrivial scrut = return (emptyFloats env
+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))
       | otherwise           = do { dc_args <- mapM (simplVar env) bs
                                          -- dc_ty_args are aready OutTypes,
                                          -- but bs are InBndrs
@@ -2810,7 +2885,8 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
                                  ; simplNonRecX env bndr con_app }
 
 -------------------
-missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr)
+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
+           -> SimplM (SimplFloats, OutExpr)
                 -- This isn't strictly an error, although it is unusual.
                 -- It's possible that the simplifier might "see" that
                 -- an inner case has no accessible alternatives before
@@ -2820,7 +2896,8 @@ missingAlt env case_bndr _ cont
   = WARN( True, text "missingAlt" <+> ppr case_bndr )
     -- See Note [Avoiding space leaks in OutType]
     let cont_ty = contResultType cont
-    in seqType cont_ty `seq` return (env, mkImpossibleExpr cont_ty)
+    in seqType cont_ty `seq`
+       return (emptyFloats env, mkImpossibleExpr cont_ty)
 
 {-
 ************************************************************************
@@ -2840,7 +2917,7 @@ and will split it into
    join floats:  $j1 = e1, $j2 = e2
    non_dupable:  let x* = [] in b; stop
 
-Putting this back togeher would give
+Putting this back together would give
    let x* = let { $j1 = e1; $j2 = e2 } in
             case e of { True -> $j1; False -> $j2 }
    in b
@@ -2850,57 +2927,23 @@ inner expression, and not around the whole thing.
 
 In contrast, any let-bindings introduced by mkDupableCont can wrap
 around the entire thing.
--}
-
 
-prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont
-                -> SimplM (SimplEnv,
-                           SimplCont,  -- For the alternatives
-                           SimplCont)  -- Wraps the entire case
--- We are considering
---     K[ case _ of { p1 -> r1; ...; pn -> rn } ]
--- where K is some enclosing continuation for the case
--- Goal: split K into two pieces Kdup,Knodup so that
---       a) Kdup can be duplicated
---       b) Knodup[Kdup[e]] = K[e]
--- The idea is that we'll transform thus:
---          Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }
---
--- We may also return some extra value bindings in SimplEnv (that scope over
--- the entire continuation) as well as some join points (thus must *not* float
--- past the continuation!).
--- Hence, the full story is this:
---     K[case _ of { p1 -> r1; ...; pn -> rn }] ==>
---     F_v[Knodup[F_j[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] }) ]]]
--- Here F_v represents some values that got floated out and F_j represents some
--- join points that got floated out.
---
--- When case-of-case is off, just make the entire continuation non-dupable
-
-prepareCaseCont env alts cont
-  | not (altsWouldDup alts)
-  = return (env, cont, mkBoringStop (contResultType cont))
-  | otherwise
-  = do { (env', cont') <- mkDupableCont env cont
-       ; return (env', cont', mkBoringStop (contResultType cont)) }
-
-prepareJoinCont :: SimplEnv -> SimplCont -> SimplM (SimplEnv, SimplCont)
-
--- Similar to prepareCaseCont, only for
---     K[let { j1 = r1; ...; jn -> rn } in _]
--- If the js are join points, this will turn into
---     Knodup[join { j1 = Kdup[r1]; ...; jn = Kdup[rn] } in Kdup[_]].
---
--- When case-of-case is off and it's a join binding, just make the entire
--- continuation non-dupable. This is necessary because otherwise
---     case (join j = ... in case e of { A -> jump j 1; ... }) of { B -> ... }
--- becomes
---     join j = case ... of { B -> ... } in
---     case (case e of { A -> jump j 1; ... }) of { B -> ... },
--- and the reference to j is invalid.
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+     case (case x of { A -> error .. ; B -> e; C -> error ..)
+       of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately.  This is more direct than creating
+join points and inlining them away.  See Trac #4930.
+-}
 
-prepareJoinCont env cont
-  = mkDupableCont env cont
+--------------------
+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont
+                  -> SimplM (SimplFloats, SimplCont)
+mkDupableCaseCont env alts cont
+  | altsWouldDup alts = mkDupableCont env cont
+  | otherwise         = return (emptyFloats env, cont)
 
 altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
 altsWouldDup []  = False        -- See Note [Bottom alternatives]
@@ -2911,115 +2954,109 @@ altsWouldDup (alt:alts)
   where
     is_bot_alt (_,_,rhs) = exprIsBottom rhs
 
-{-
-Note [Bottom alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we have
-     case (case x of { A -> error .. ; B -> e; C -> error ..)
-       of alts
-then we can just duplicate those alts because the A and C cases
-will disappear immediately.  This is more direct than creating
-join points and inlining them away.  See Trac #4930.
--}
-
 -------------------------
 mkDupableCont :: SimplEnv -> SimplCont
-              -> SimplM ( SimplEnv    -- Incoming SimplEnv augmented with
-                                      --   extra let/join-floats and in-scope variables
-                        , SimplCont)  -- dup_cont: duplicable continuation
-mkDupableCont env cont
-  = mk_dupable_cont env cont
+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with
+                                       --   extra let/join-floats and in-scope variables
+                        , SimplCont)   -- dup_cont: duplicable continuation
 
--------------------------
-mk_dupable_cont :: SimplEnv -> SimplCont
-                -> SimplM (SimplEnv, SimplCont)
-mk_dupable_cont env cont
+mkDupableCont env cont
   | contIsDupable cont
-  = return (env, cont)
+  = return (emptyFloats env, cont)
 
-mk_dupable_cont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
+mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
 
-mk_dupable_cont env (CastIt ty cont)
-  = do  { (env', cont') <- mk_dupable_cont env cont
-        ; return (env', CastIt ty cont') }
+mkDupableCont env (CastIt ty cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, CastIt ty cont') }
 
 -- Duplicating ticks for now, not sure if this is good or not
-mk_dupable_cont env (TickIt t cont)
-  = do  { (env', cont') <- mk_dupable_cont env cont
-        ; return (env', TickIt t cont') }
+mkDupableCont env (TickIt t cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, TickIt t cont') }
 
-mk_dupable_cont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
-                                , sc_body = body, sc_env = se, sc_cont = cont})
+mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
+                              , sc_body = body, sc_env = se, sc_cont = cont})
   -- See Note [Duplicating StrictBind]
-  = do { let sb_env = se `setInScopeAndZapFloats` env
+  = do { let sb_env = se `setInScopeFromE` env
        ; (sb_env1, bndr') <- simplBinder sb_env bndr
-       ; (sb_env', join_inner) <- simplLam sb_env1 bndrs body cont
-          -- No need to use mk_dupable_cont before simplLam; we
+       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
+          -- No need to use mkDupableCont before simplLam; we
           -- use cont once here, and then share the result if necessary
-       ; let join_body = wrapFloats sb_env' join_inner
+
+       ; let join_body = wrapFloats floats1 join_inner
              res_ty    = contResultType cont
-       ; dflags <- getDynFlags
-       ; (env2, body2)
-            <- if exprIsDupable dflags join_body
-               then return (env, join_body)
+
+       ; (floats2, body2)
+            <- if exprIsDupable (seDynFlags env) join_body
+               then return (emptyFloats env, join_body)
                else do { join_bndr <- newJoinId [bndr'] res_ty
                        ; let join_call = App (Var join_bndr) (Var bndr')
                              join_rhs  = Lam (setOneShotLambda bndr') join_body
-                       ; return (addNonRec env join_bndr join_rhs, join_call) }
-       ; return ( env2
+                             join_bind = NonRec join_bndr join_rhs
+                             floats    = emptyFloats env `extendFloats` join_bind
+                       ; return (floats, join_call) }
+       ; return ( floats2
                 , StrictBind { sc_bndr = bndr', sc_bndrs = []
                              , sc_body = body2
-                             , sc_env  = zapSubstEnv se
+                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2
+                                         -- See Note [StaticEnv invariant] in SimplUtils
                              , sc_dup  = OkToDup
                              , sc_cont = mkBoringStop res_ty } ) }
 
-mk_dupable_cont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
+mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
         -- See Note [Duplicating StrictArg]
         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
-  = do { (env', cont')  <- mk_dupable_cont env cont
-       ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info)
-       ; return (env'', StrictArg { sc_fun = info { ai_args = args' }
-                                  , sc_cci = cci
-                                  , sc_cont = cont'
-                                  , sc_dup = OkToDup} ) }
-
-mk_dupable_cont env (ApplyToTy { sc_cont = cont
-                               , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
-  = do  { (env', cont') <- mk_dupable_cont env cont
-        ; return (env', ApplyToTy { sc_cont = cont'
-                                  , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
-
-mk_dupable_cont env (ApplyToVal { sc_arg = arg, sc_dup = dup
-                                , sc_env = se, sc_cont = cont })
+  = do { (floats1, cont') <- mkDupableCont env cont
+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
+                                           (ai_args info)
+       ; return ( foldl' addLetFloats floats1 floats_s
+                , StrictArg { sc_fun = info { ai_args = args' }
+                            , sc_cci = cci
+                            , sc_cont = cont'
+                            , sc_dup = OkToDup} ) }
+
+mkDupableCont env (ApplyToTy { sc_cont = cont
+                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, ApplyToTy { sc_cont = cont'
+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
+
+mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
+                              , sc_env = se, sc_cont = cont })
   =     -- e.g.         [...hole...] (...arg...)
         --      ==>
         --              let a = ...arg...
         --              in [...hole...] a
         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
-    do  { (env', cont') <- mk_dupable_cont env cont
+    do  { (floats1, cont') <- mkDupableCont env cont
+        ; let env' = env `setInScopeFromF` floats1
         ; (_, se', arg') <- simplArg env' dup se arg
-        ; (env'', arg'') <- makeTrivial NotTopLevel env' (fsLit "karg") arg'
-        ; return (env'', ApplyToVal { sc_arg = arg'', sc_env = se'
-                                    , sc_dup = OkToDup, sc_cont = cont' }) }
-
-mk_dupable_cont env (Select { sc_bndr = case_bndr, sc_alts = alts
-                            , sc_env = se, sc_cont = cont })
+        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'
+        ; let all_floats = floats1 `addLetFloats` let_floats2
+        ; return ( all_floats
+                 , ApplyToVal { sc_arg = arg''
+                              , sc_env = se' `setInScopeFromF` all_floats
+                                         -- Ensure that sc_env includes the free vars of
+                                         -- arg'' in its in-scope set, even if makeTrivial
+                                         -- has turned arg'' into a fresh variable
+                                         -- See Note [StaticEnv invariant] in SimplUtils
+                              , sc_dup = OkToDup, sc_cont = cont' }) }
+
+mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
+                          , sc_env = se, sc_cont = cont })
   =     -- e.g.         (case [...hole...] of { pi -> ei })
         --      ===>
         --              let ji = \xij -> ei
         --              in case [...hole...] of { pi -> ji xij }
         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
     do  { tick (CaseOfCase case_bndr)
-        ; (env', alt_cont, wrap_cont) <- prepareCaseCont env alts cont
-                -- NB: We call prepareCaseCont here.  If there is only one
-                -- alternative, then dup_cont may be big, but that's ok
-                -- because we push it into the single alternative, and then
-                -- use mkDupableAlt to turn that simplified alternative into
-                -- a join point if it's too big to duplicate.
+        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont
+                -- NB: We call mkDupableCaseCont here to make cont duplicable
+                --     (if necessary, depending on the number of alts)
                 -- And this is important: see Note [Fusing case continuations]
 
-        ; let alt_env = se `setInScopeAndZapFloats` env'
-
+        ; let alt_env = se `setInScopeFromF` floats
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts
         -- Safe to say that there are no handled-cons for the DEFAULT case
@@ -3034,27 +3071,25 @@ mk_dupable_cont env (Select { sc_bndr = case_bndr, sc_alts = alts
         -- NB: we don't use alt_env further; it has the substEnv for
         --     the alternatives, and we don't want that
 
-        ; (join_binds, alts'') <- mkDupableAlts case_bndr' alts'
-        ; let env'' = foldl (\env (j,r) -> addNonRec env j r) env' join_binds
-
-        ; return (env'',  -- Note [Duplicated env]
-                  Select { sc_dup  = OkToDup
-                         , sc_bndr = case_bndr', sc_alts = alts''
-                         , sc_env  = zapSubstEnv env''
-                         , sc_cont = wrap_cont } ) }
-
-mkDupableAlts :: OutId -> [OutAlt] -> SimplM ([(JoinId, OutExpr)], [OutAlt])
-mkDupableAlts case_bndr' the_alts
-  = do { dflags <- getDynFlags
-       ; (mb_join_floats, dup_alts)
-             <- mapAndUnzipM (mkDupableAlt dflags case_bndr') the_alts
-       ; return (catMaybes mb_join_floats, dup_alts) }
-
-mkDupableAlt :: DynFlags -> OutId -> OutAlt
-             -> SimplM (Maybe (JoinId,OutExpr), OutAlt)
-mkDupableAlt dflags case_bndr (con, bndrs', rhs')
+        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')
+                                              emptyJoinFloats alts'
+
+        ; let all_floats = floats `addJoinFloats` join_floats
+                           -- Note [Duplicated env]
+        ; return (all_floats
+                 , Select { sc_dup  = OkToDup
+                          , sc_bndr = case_bndr'
+                          , sc_alts = alts''
+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats
+                                      -- See Note [StaticEnv invariant] in SimplUtils
+                          , sc_cont = mkBoringStop (contResultType cont) } ) }
+
+mkDupableAlt :: DynFlags -> OutId
+             -> JoinFloats -> OutAlt
+             -> SimplM (JoinFloats, OutAlt)
+mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')
   | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
-  = return (Nothing, (con, bndrs', rhs'))
+  = return (jfloats, (con, bndrs', rhs'))
 
   | otherwise
   = do  { let rhs_ty'  = exprType rhs'
@@ -3099,7 +3134,8 @@ mkDupableAlt dflags case_bndr (con, bndrs', rhs')
         ; let join_call = mkApps (Var join_bndr) final_args
               alt'      = (con, bndrs', join_call)
 
-        ; return (Just (join_bndr, join_rhs), alt') }
+        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)
+                 , alt') }
                 -- See Note [Duplicated env]
 
 {-
@@ -3178,7 +3214,7 @@ and c is unused.
 Note [Duplicated env]
 ~~~~~~~~~~~~~~~~~~~~~
 Some of the alternatives are simplified, but have not been turned into a join point
-So they *must* have an zapped subst-env.  So we can't use completeNonRecX to
+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to
 bind the join point, because it might to do PostInlineUnconditionally, and
 we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
 but zapping it (as we do in mkDupableCont, the Select case) is safe, and
@@ -3347,17 +3383,24 @@ because we don't know its usage in each RHS separately
 -}
 
 simplLetUnfolding :: SimplEnv-> TopLevelFlag
-                  -> Maybe SimplCont
+                  -> MaybeJoinCont
                   -> InId
-                  -> OutExpr
+                  -> OutExpr -> OutType
                   -> Unfolding -> SimplM Unfolding
-simplLetUnfolding env top_lvl cont_mb id new_rhs unf
+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf
   | isStableUnfolding unf
-  = simplUnfolding env top_lvl cont_mb id unf
+  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty
+  | isExitJoinId id
+  = return noUnfolding -- See Note [Do not inline exit join points] in Exitify
   | otherwise
+  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs
+
+-------------------
+mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource
+               -> InId -> OutExpr -> SimplM Unfolding
+mkLetUnfolding dflags top_lvl src id new_rhs
   = is_bottoming `seq`  -- See Note [Force bottoming field]
-    do { dflags <- getDynFlags
-       ; return (mkUnfolding dflags InlineRhs is_top_lvl is_bottoming new_rhs) }
+    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)
             -- We make an  unfolding *even for loop-breakers*.
             -- Reason: (a) It might be useful to know that they are WHNF
             --         (b) In TidyPgm we currently assume that, if we want to
@@ -3368,53 +3411,62 @@ simplLetUnfolding env top_lvl cont_mb id new_rhs unf
     is_top_lvl   = isTopLevel top_lvl
     is_bottoming = isBottomingId id
 
-simplUnfolding :: SimplEnv -> TopLevelFlag
-               -> Maybe SimplCont  -- Just k => a join point with continuation k
-               -> InId
-               -> Unfolding -> SimplM Unfolding
+-------------------
+simplStableUnfolding :: SimplEnv -> TopLevelFlag
+                     -> MaybeJoinCont  -- Just k => a join point with continuation k
+                     -> InId
+                     -> Unfolding -> OutType -> SimplM Unfolding
 -- Note [Setting the new unfolding]
-simplUnfolding env top_lvl mb_cont id unf
+simplStableUnfolding env top_lvl mb_cont id unf rhs_ty
   = case unf of
-      NoUnfolding -> return unf
+      NoUnfolding   -> return unf
       BootUnfolding -> return unf
-      OtherCon {} -> return unf
+      OtherCon {}   -> return unf
 
       DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
-        -> do { (env', bndrs') <- simplBinders rule_env bndrs
+        -> do { (env', bndrs') <- simplBinders unf_env bndrs
               ; args' <- mapM (simplExpr env') args
               ; return (mkDFunUnfolding bndrs' con args') }
 
       CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
         | isStableSource src
-        -> do { expr' <- case mb_cont of
-                           Just cont -> simplJoinRhs rule_env id expr cont
-                           Nothing   -> simplExpr rule_env expr
+        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]
+                           Just cont -> simplJoinRhs unf_env id expr cont
+                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)
               ; case guide of
-                  UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok }  -- Happens for INLINE things
-                     -> let guide' = UnfWhen { ug_arity = arity, ug_unsat_ok = sat_ok
-                                             , ug_boring_ok = inlineBoringOk expr' }
+                  UnfWhen { ug_arity = arity
+                          , ug_unsat_ok = sat_ok
+                          , ug_boring_ok = boring_ok
+                          }
+                          -- Happens for INLINE things
+                     -> let guide' =
+                              UnfWhen { ug_arity = arity
+                                      , ug_unsat_ok = sat_ok
+                                      , ug_boring_ok =
+                                          boring_ok || inlineBoringOk expr'
+                                      }
                         -- Refresh the boring-ok flag, in case expr'
                         -- has got small. This happens, notably in the inlinings
                         -- for dfuns for single-method classes; see
                         -- Note [Single-method classes] in TcInstDcls.
                         -- A test case is Trac #4138
+                        -- But retain a previous boring_ok of True; e.g. see
+                        -- the way it is set in calcUnfoldingGuidanceWithArity
                         in return (mkCoreUnfolding src is_top_lvl expr' guide')
                             -- See Note [Top-level flag on inline rules] in CoreUnfold
 
                   _other              -- Happens for INLINABLE things
-                     -> is_bottoming `seq` -- See Note [Force bottoming field]
-                        do { dflags <- getDynFlags
-                           ; return (mkUnfolding dflags src is_top_lvl is_bottoming expr') } }
+                     -> mkLetUnfolding dflags top_lvl src id expr' }
                 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
                 -- unfolding, and we need to make sure the guidance is kept up
                 -- to date with respect to any changes in the unfolding.
 
         | otherwise -> return noUnfolding   -- Discard unstable unfoldings
   where
-    is_top_lvl   = isTopLevel top_lvl
-    is_bottoming = isBottomingId id
-    act          = idInlineActivation id
-    rule_env     = updMode (updModeForStableUnfoldings act) env
+    dflags     = seDynFlags env
+    is_top_lvl = isTopLevel top_lvl
+    act        = idInlineActivation id
+    unf_env    = updMode (updModeForStableUnfoldings act) env
          -- See Note [Simplifying inside stable unfoldings] in SimplUtils
 
 {-
@@ -3435,7 +3487,7 @@ Note [Setting the new unfolding]
   important: if exprIsConApp says 'yes' for a recursive thing, then we
   can get into an infinite loop
 
-If there's an stable unfolding on a loop breaker (which happens for
+If there's a stable unfolding on a loop breaker (which happens for
 INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the
 user did say 'INLINE'.  May need to revisit this choice.
 
@@ -3456,20 +3508,24 @@ to apply in that function's own right-hand side.
 See Note [Forming Rec groups] in OccurAnal
 -}
 
-addBndrRules :: SimplEnv -> InBndr -> OutBndr -> SimplM (SimplEnv, OutBndr)
+addBndrRules :: SimplEnv -> InBndr -> OutBndr
+             -> MaybeJoinCont   -- Just k for a join point binder
+                                -- Nothing otherwise
+             -> SimplM (SimplEnv, OutBndr)
 -- Rules are added back into the bin
-addBndrRules env in_id out_id
+addBndrRules env in_id out_id mb_cont
   | null old_rules
   = return (env, out_id)
   | otherwise
-  = do { new_rules <- simplRules env (Just (idName out_id)) old_rules
+  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont
        ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules
        ; return (modifyInScope env final_id, final_id) }
   where
     old_rules = ruleInfoRules (idSpecialisation in_id)
 
-simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule]
-simplRules env mb_new_nm rules
+simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]
+           -> MaybeJoinCont -> SimplM [CoreRule]
+simplRules env mb_new_id rules mb_cont
   = mapM simpl_rule rules
   where
     simpl_rule rule@(BuiltinRule {})
@@ -3479,11 +3535,29 @@ simplRules env mb_new_nm rules
                           , ru_fn = fn_name, ru_rhs = rhs })
       = do { (env', bndrs') <- simplBinders env bndrs
            ; let rhs_ty = substTy env' (exprType rhs)
-                 rule_cont = mkBoringStop rhs_ty
-                 rule_env  = updMode updModeForRules env'
+                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]
+                                Nothing   -> mkBoringStop rhs_ty
+                                Just cont -> ASSERT2( join_ok, bad_join_msg )
+                                             cont
+                 rule_env = updMode updModeForRules env'
+                 fn_name' = case mb_new_id of
+                              Just id -> idName id
+                              Nothing -> fn_name
+
+                 -- join_ok is an assertion check that the join-arity of the
+                 -- binder matches that of the rule, so that pushing the
+                 -- continuation into the RHS makes sense
+                 join_ok = case mb_new_id of
+                             Just id | Just join_arity <- isJoinId_maybe id
+                                     -> length args == join_arity
+                             _ -> False
+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule
+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]
+
            ; args' <- mapM (simplExpr rule_env) args
-           ; rhs'  <- simplExprC rule_env rhs rule_cont
+           ; rhs'  <- simplExprC rule_env rhs rhs_cont
            ; return (rule { ru_bndrs = bndrs'
-                          , ru_fn    = mb_new_nm `orElse` fn_name
+                          , ru_fn    = fn_name'
                           , ru_args  = args'
                           , ru_rhs   = rhs' }) }
+
diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
index 2acc815125..694aa4ebf7 100644
--- a/compiler/simplStg/RepType.hs
+++ b/compiler/simplStg/RepType.hs
@@ -23,6 +23,8 @@ module RepType
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import BasicTypes (Arity, RepArity)
 import DataCon
 import Outputable
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 4943f525af..36bf5101d6 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -10,93 +10,67 @@ module SimplStg ( stg2stg ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 
-import CostCentre       ( CollectedCCs )
-import SCCfinal         ( stgMassageForProfiling )
 import StgLint          ( lintStgTopBindings )
 import StgStats         ( showStgStats )
 import UnariseStg       ( unarise )
 import StgCse           ( stgCse )
 
 import DynFlags
-import Module           ( Module )
 import ErrUtils
-import SrcLoc
-import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )
+import UniqSupply       ( mkSplitUniqSupply )
 import Outputable
 import Control.Monad
 
 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
-        -> Module                    -- module name (profiling only)
         -> [StgTopBinding]           -- input...
-        -> IO ( [StgTopBinding]      -- output program...
-              , CollectedCCs)        -- cost centre information (declared and used)
+        -> IO [StgTopBinding]        -- output program
 
-stg2stg dflags module_name binds
+stg2stg dflags binds
   = do  { showPass dflags "Stg2Stg"
         ; us <- mkSplitUniqSupply 'g'
 
-        ; when (dopt Opt_D_verbose_stg2stg dflags)
-               (putLogMsg dflags NoReason SevDump noSrcSpan
-                  (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
-
-        ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
-
                 -- Do the main business!
-        ; let (us0, us1) = splitUniqSupply us'
-        ; (processed_binds, _, cost_centres)
-                <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
-
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
-                        (pprStgTopBindings processed_binds)
+                        (pprStgTopBindings binds)
 
-        ; let un_binds = unarise us1 processed_binds
+        ; stg_linter False "Pre-unarise" binds
+        ; let un_binds = unarise us binds
+        ; stg_linter True "Unarise" un_binds
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
                         (pprStgTopBindings un_binds)
 
-        ; return (un_binds, cost_centres)
-   }
+        ; foldM do_stg_pass un_binds (getStgToDo dflags)
+        }
 
   where
-    stg_linter = if gopt Opt_DoStgLinting dflags
-                 then lintStgTopBindings
-                 else ( \ _whodunnit binds -> binds )
+    stg_linter unarised
+      | gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
+      | otherwise                    = \ _whodunnit _binds -> return ()
 
     -------------------------------------------
-    do_stg_pass (binds, us, ccs) to_do
+    do_stg_pass binds to_do
       = case to_do of
           D_stg_stats ->
-             trace (showStgStats binds)
-             end_pass us "StgStats" ccs binds
-
-          StgDoMassageForProfiling ->
-             {-# SCC "ProfMassage" #-}
-             let
-                 (us1, us2) = splitUniqSupply us
-                 (collected_CCs, binds3)
-                   = stgMassageForProfiling dflags module_name us1 binds
-             in
-             end_pass us2 "ProfMassage" collected_CCs binds3
+             trace (showStgStats binds) (return binds)
 
           StgCSE ->
              {-# SCC "StgCse" #-}
              let
                  binds' = stgCse binds
              in
-             end_pass us "StgCse" ccs binds'
+             end_pass "StgCse" binds'
 
-    end_pass us2 what ccs binds2
+    end_pass what binds2
       = do -- report verbosely, if required
            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
-              (vcat (map ppr binds2))
-           let linted_binds = stg_linter what binds2
-           return (linted_binds, us2, ccs)
-            -- return: processed binds
-            --         UniqueSupply for the next guy to use
-            --         cost-centres to be declared/registered (specialised)
-            --         add to description of what's happened (reverse order)
+              (pprStgTopBindings binds2)
+           stg_linter True what binds2
+           return binds2
 
 -- -----------------------------------------------------------------------------
 -- StgToDo:  abstraction of stg-to-stg passes to run.
@@ -104,14 +78,12 @@ stg2stg dflags module_name binds
 -- | Optional Stg-to-Stg passes.
 data StgToDo
   = StgCSE
-  | StgDoMassageForProfiling  -- should be (next to) last
   | D_stg_stats
 
 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
 getStgToDo :: DynFlags -> [StgToDo]
 getStgToDo dflags
   = [ StgCSE                   | gopt Opt_StgCSE dflags] ++
-    [ StgDoMassageForProfiling | WayProf `elem` ways dflags] ++
     [ D_stg_stats              | stg_stats ]
   where
         stg_stats = gopt Opt_StgStats dflags
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 6bd6adc7ec..1ae1213960 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -5,9 +5,9 @@ Note [CSE for Stg]
 ~~~~~~~~~~~~~~~~~~
 This module implements a simple common subexpression elimination pass for STG.
 This is useful because there are expressions that we want to common up (because
-they are operational equivalent), but that we cannot common up in Core, because
+they are operationally equivalent), but that we cannot common up in Core, because
 their types differ.
-This was original reported as #9291.
+This was originally reported as #9291.
 
 There are two types of common code occurrences that we aim for, see
 note [Case 1: CSEing allocated closures] and
@@ -16,7 +16,7 @@ note [Case 2: CSEing case binders] below.
 
 Note [Case 1: CSEing allocated closures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The fist kind of CSE opportunity we aim for is generated by this Haskell code:
+The first kind of CSE opportunity we aim for is generated by this Haskell code:
 
     bar :: a -> (Either Int a, Either Bool a)
     bar x = (Right x, Right x)
@@ -70,6 +70,8 @@ and nothing stops us from transforming that to
 -}
 module StgCse (stgCse) where
 
+import GhcPrelude
+
 import DataCon
 import Id
 import StgSyn
@@ -78,7 +80,7 @@ import VarEnv
 import CoreSyn (AltCon(..))
 import Data.List (mapAccumL)
 import Data.Maybe (fromMaybe)
-import TrieMap
+import CoreMap
 import NameEnv
 import Control.Monad( (>=>) )
 
@@ -137,7 +139,7 @@ data CseEnv = CseEnv
         --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,
         --     we note this here as x ↦ y.
     , ce_bndrMap     :: IdEnv OutId
-        --   If we come across a case expression case x as b of … with a trivial
+        -- ^ If we come across a case expression case x as b of … with a trivial
         --   binder, we add b ↦ x to this.
         --   This map is *only* used when looking something up in the ce_conAppMap.
         --   See Note [Trivial case scrutinee]
@@ -217,7 +219,7 @@ substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
 
 -- Functions to enter binders
 
--- This is much simpler than the requivalent code in CoreSubst:
+-- This is much simpler than the equivalent code in CoreSubst:
 --  * We do not substitute type variables, and
 --  * There is nothing relevant in IdInfo at this stage
 --    that needs substitutions.
@@ -300,7 +302,7 @@ stgCseExpr env (StgCase scrut bndr ty alts)
     env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1
                  -- See Note [Trivial case scrutinee]
          | otherwise                         = env1
-    alts' = map (stgCseAlt env2 bndr') alts
+    alts' = map (stgCseAlt env2 ty bndr') alts
 
 
 -- A constructor application.
@@ -327,14 +329,24 @@ stgCseExpr env (StgLetNoEscape binds body)
 
 -- Case alternatives
 -- Extend the CSE environment
-stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt
-stgCseAlt env case_bndr (DataAlt dataCon, args, rhs)
+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
     = let (env1, args') = substBndrs env args
-          env2 = addDataCon case_bndr dataCon (map StgVarArg args') env1
+          env2
+            -- To avoid dealing with unboxed sums StgCse runs after unarise and
+            -- should maintain invariants listed in Note [Post-unarisation
+            -- invariants]. One of the invariants is that some binders are not
+            -- used (unboxed tuple case binders) which is what we check with
+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we
+            -- don't add it to the CSE env. See also #15300.
+            | stgCaseBndrInScope ty True -- CSE runs after unarise
+            = addDataCon case_bndr dataCon (map StgVarArg args') env1
+            | otherwise
+            = env1
             -- see note [Case 2: CSEing case binders]
           rhs' = stgCseExpr env2 rhs
       in (DataAlt dataCon, args', rhs')
-stgCseAlt env _ (altCon, args, rhs)
+stgCseAlt env _ _ (altCon, args, rhs)
     = let (env1, args') = substBndrs env args
           rhs' = stgCseExpr env1 rhs
       in (altCon, args', rhs')
@@ -362,7 +374,7 @@ stgCsePairs env0 ((b,e):pairs)
     mbCons = maybe id (:)
 
 -- The RHS of a binding.
--- If it is an constructor application, either short-cut it or extend the environment
+-- If it is a constructor application, either short-cut it or extend the environment
 stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
 stgCseRhs env bndr (StgRhsCon ccs dataCon args)
     | Just other_bndr <- envLookup dataCon args' env
@@ -438,7 +450,7 @@ we first replace v with r2. Next we want to replace Right r2 with r1. But the
 ce_conAppMap contains Right a!
 
 Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use
-this subsitution before looking Right r2 up in ce_conAppMap, and everything
+this substitution before looking Right r2 up in ce_conAppMap, and everything
 works out.
 
 Note [Free variables of an StgClosure]
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 3f75ae23fa..712ec2d22e 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -27,6 +27,8 @@ module StgStats ( showStgStats ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import StgSyn
 
 import Id (Id)
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 2e8fbda02b..5c271c2ea0 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -196,20 +196,22 @@ module UnariseStg (unarise) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import BasicTypes
 import CoreSyn
 import DataCon
 import FastString (FastString, mkFastString)
 import Id
-import Literal (Literal (..))
-import MkCore (aBSENT_ERROR_ID)
+import Literal
+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
 import MkId (voidPrimId, voidArgId)
 import MonadUtils (mapAccumLM)
 import Outputable
 import RepType
 import StgSyn
 import Type
-import TysPrim (intPrimTy)
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
 import TysWiredIn
 import UniqSupply
 import Util
@@ -332,7 +334,7 @@ unariseExpr _ e@StgLam{}
   = pprPanic "unariseExpr: found lambda" (ppr e)
 
 unariseExpr rho (StgCase scrut bndr alt_ty alts)
-  -- a tuple/sum binders in the scrutinee can always be eliminated
+  -- tuple/sum binders in the scrutinee can always be eliminated
   | StgApp v [] <- scrut
   , Just (MultiVal xs) <- lookupVarEnv rho v
   = elimCase rho xs bndr alt_ty alts
@@ -349,7 +351,8 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
   = do scrut' <- unariseExpr rho scrut
        alts'  <- unariseAlts rho alt_ty bndr alts
        return (StgCase scrut' bndr alt_ty alts')
-                       -- bndr will be dead after unarise
+                       -- bndr may have a unboxed sum/tuple type but it will be
+                       -- dead after unarise (checked in StgLint)
 
 unariseExpr rho (StgLet bind e)
   = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
@@ -475,7 +478,7 @@ unariseSumAlt rho _ (DEFAULT, _, e)
 unariseSumAlt rho args (DataAlt sumCon, bs, e)
   = do let rho' = mapSumIdBinders bs args rho
        e' <- unariseExpr rho' e
-       return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
 
 unariseSumAlt _ scrt alt
   = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
@@ -561,7 +564,7 @@ mkUbxSum dc ty_args args0
       tag = dataConTag dc
 
       layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
-      tag_arg  = StgLitArg (MachInt (fromIntegral tag))
+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
       arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
 
       mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
@@ -574,9 +577,10 @@ mkUbxSum dc ty_args args0
         = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
 
       slotRubbishArg :: SlotTy -> StgArg
-      slotRubbishArg PtrSlot    = StgVarArg aBSENT_ERROR_ID
-      slotRubbishArg WordSlot   = StgLitArg (MachWord 0)
-      slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
       slotRubbishArg FloatSlot  = StgLitArg (MachFloat 0)
       slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
     in
@@ -640,6 +644,35 @@ So in short, when we have a void id,
                          in argument position of a DataCon application.
 -}
 
+unariseArgBinder
+    :: Bool -- data con arg?
+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseArgBinder is_con_arg rho x =
+  case typePrimRep (idType x) of
+    []
+      | is_con_arg
+      -> return (extendRho rho x (MultiVal []), [])
+      | otherwise -- fun arg, do not remove void binders
+      -> return (extendRho rho x (MultiVal []), [voidArgId])
+
+    [rep]
+      -- Arg represented as single variable, but original type may still be an
+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
+      --
+      -- While not unarising the binder in this case does not break any programs
+      -- (because it unarises to a single variable), it triggers StgLint as we
+      -- break the the post-unarisation invariant that says unboxed tuple/sum
+      -- binders should vanish. See Note [Post-unarisation invariants].
+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
+      | otherwise
+      -> return (rho, [x])
+
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
 --------------------------------------------------------------------------------
 
 -- | MultiVal a function argument. Never returns an empty list.
@@ -658,16 +691,9 @@ unariseFunArgs = concatMap . unariseFunArg
 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
 
-unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
 -- Result list of binders is never empty
-unariseFunArgBinder rho x  =
-  case typePrimRep (idType x) of
-    []   -> return (extendRho rho x (MultiVal []), [voidArgId])
-                           -- NB: do not remove void binders
-    [_]  -> return (rho, [x])
-    reps -> do
-      xs <- mkIds (mkFastString "us") (map primRepToType reps)
-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
 
 --------------------------------------------------------------------------------
 
@@ -682,7 +708,9 @@ unariseConArg rho (StgVarArg x) =
                                   -- Here realWorld# is not in the envt, but
                                   -- is a void, and so should be eliminated
       | otherwise -> [StgVarArg x]
-unariseConArg _ arg = [arg]       -- We have no void literals
+unariseConArg _ arg@(StgLitArg lit) =
+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
+    [arg]
 
 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
 unariseConArgs = concatMap . unariseConArg
@@ -690,13 +718,10 @@ unariseConArgs = concatMap . unariseConArg
 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
 
+-- Different from `unariseFunArgBinder`: result list of binders may be empty.
+-- See DataCon applications case in Note [Post-unarisation invariants].
 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-unariseConArgBinder rho x =
-  case typePrimRep (idType x) of
-    [_]  -> return (rho, [x])
-    reps -> do
-      xs <- mkIds (mkFastString "us") (map primRepToType reps)
-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseConArgBinder = unariseArgBinder True
 
 unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
 unariseFreeVars rho fvs
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index b5606754e6..ad6a0757cb 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -28,6 +28,8 @@ module Rules (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn          -- All of it
 import Module           ( Module, ModuleSet, elemModuleSet )
 import CoreSubst
@@ -38,7 +40,7 @@ import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
                           stripTicksTopT, stripTicksTopE,
                           isJoinBind )
 import PprCore          ( pprRules )
-import Type             ( Type, substTy, mkTCvSubst )
+import Type             ( Type, Kind, substTy, mkTCvSubst )
 import TcType           ( tcSplitTyConApp_maybe )
 import TysWiredIn       ( anyTypeOfKind )
 import Coercion
@@ -53,7 +55,7 @@ import NameSet
 import NameEnv
 import UniqFM
 import Unify            ( ruleMatchTyKiX )
-import BasicTypes       ( Activation, CompilerPhase, isActive, pprRuleName )
+import BasicTypes
 import DynFlags         ( DynFlags )
 import Outputable
 import FastString
@@ -288,9 +290,10 @@ addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)
   = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)
 
 addIdSpecialisations :: Id -> [CoreRule] -> Id
-addIdSpecialisations id []
-  = id
 addIdSpecialisations id rules
+  | null rules
+  = id
+  | otherwise
   = setIdSpecialisation id $
     extendRuleInfo (idSpecialisation id) rules
 
@@ -310,9 +313,8 @@ ruleIsVisible _ BuiltinRule{} = True
 ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }
     = notOrphan orph || origin `elemModuleSet` vis_orphs
 
-{-
-Note [Where rules are found]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Where rules are found]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The rules for an Id come from two places:
   (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
   (b) rules added in other modules, stored in the global RuleBase (imp_rules)
@@ -348,7 +350,7 @@ mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
 
 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
 extendRuleBaseList rule_base new_guys
-  = foldl extendRuleBase rule_base new_guys
+  = foldl' extendRuleBase rule_base new_guys
 
 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
@@ -411,21 +413,20 @@ lookupRule dflags in_scope is_active fn args rules
 findBest :: (Id, [CoreExpr])
          -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
 -- All these pairs matched the expression
--- Return the pair the the most specific rule
+-- Return the pair the most specific rule
 -- The (fn,args) is just for overlap reporting
 
 findBest _      (rule,ans)   [] = (rule,ans)
 findBest target (rule1,ans1) ((rule2,ans2):prs)
   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
-  | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg
-                        then ppr rule
-                        else doubleQuotes (ftext (ruleName rule))
+  | debugIsOn = let pp_rule rule
+                      = ifPprDebug (ppr rule)
+                                   (doubleQuotes (ftext (ruleName rule)))
                 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
-                         (vcat [ sdocWithPprDebug $ \dbg -> if dbg
-                                   then text "Expression to match:" <+> ppr fn
-                                        <+> sep (map ppr args)
-                                   else empty
+                         (vcat [ whenPprDebug $
+                                 text "Expression to match:" <+> ppr fn
+                                 <+> sep (map ppr args)
                                , text "Rule 1:" <+> pp_rule rule1
                                , text "Rule 2:" <+> pp_rule rule2]) $
                 findBest target (rule1,ans1) prs
@@ -517,7 +518,7 @@ matchRule _ in_scope is_active _ args rough_args
   | ruleCantMatch tpl_tops rough_args = Nothing
   | otherwise
   = case matchN in_scope rule_name tpl_vars tpl_args args of
-        Nothing                        -> Nothing
+        Nothing                       -> Nothing
         Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
                                                rule_fn `mkApps` tpl_vals)
   where
@@ -535,58 +536,82 @@ matchN  :: InScopeEnv
 
 matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es
   = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es
-        ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars
+        ; let (_, matched_es) = mapAccumL lookup_tmpl subst $
+                                tmpl_vars `zip` tmpl_vars1
         ; return (rs_binds subst, matched_es) }
   where
-    init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
-                  -- See Note [Template binders]
+    (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
+                  -- See Note [Cloning the template binders]
 
-    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env
-                   , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
-                   , rv_unf = id_unf }
+    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1
+                   , rv_lcl   = init_rn_env
+                   , rv_fltR  = mkEmptySubst (rnInScopeSet init_rn_env)
+                   , rv_unf   = id_unf }
 
     go _    subst []     _      = Just subst
     go _    _     _      []     = Nothing       -- Fail if too few actual args
     go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
                                      ; go menv subst1 ts es }
 
-    lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr)
-    lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var
-        | isId tmpl_var
-        = case lookupVarEnv id_subst tmpl_var of
+    lookup_tmpl :: RuleSubst -> (InVar,OutVar) -> (RuleSubst, CoreExpr)
+                   -- Need to return a RuleSubst solely for the benefit of mk_fake_ty
+    lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })
+                (tmpl_var, tmpl_var1)
+        | isId tmpl_var1
+        = case lookupVarEnv id_subst tmpl_var1 of
              Just e -> (rs, e)
-             Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var
-                     , let co_expr = Coercion refl_co
-                     -> (rs { rs_id_subst = extendVarEnv id_subst tmpl_var co_expr }, co_expr)
+             Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1
+                     , let co_expr   = Coercion refl_co
+                           id_subst' = extendVarEnv id_subst tmpl_var1 co_expr
+                           rs'       = rs { rs_id_subst = id_subst' }
+                     -> (rs', co_expr) -- See Note [Unbound RULE binders]
                      | otherwise
                      -> unbound tmpl_var
         | otherwise
-        = case lookupVarEnv tv_subst tmpl_var of
+        = case lookupVarEnv tv_subst tmpl_var1 of
              Just ty -> (rs, Type ty)
-             Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty)
-                        -- See Note [Unbound RULE binders]
+             Nothing -> (rs', Type fake_ty) -- See Note [Unbound RULE binders]
         where
-          fake_ty = anyTypeOfKind kind
-          cv_subst = to_co_env id_subst
-          kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
-                              (tyVarKind tmpl_var)
-
-          to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env
-            -- It's OK to use nonDetFoldUFM_Directly because we forget the
-            -- order immediately by creating a new env
-          to_co uniq expr env
-            | Just co <- exprToCoercion_maybe expr
-            = extendVarEnv_Directly env uniq co
-
-            | otherwise
-            = env
-
-    unbound var = pprPanic "Template variable unbound in rewrite rule" $
-                  vcat [ text "Variable:" <+> ppr var
-                       , text "Rule" <+> pprRuleName rule_name
-                       , text "Rule bndrs:" <+> ppr tmpl_vars
-                       , text "LHS args:" <+> ppr tmpl_es
-                       , text "Actual args:" <+> ppr target_es ]
+          rs'     = rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var1 fake_ty }
+          fake_ty = mk_fake_ty in_scope rs tmpl_var1
+                    -- This call is the sole reason we accumulate
+                    -- RuleSubst in lookup_tmpl
+
+    unbound tmpl_var
+       = pprPanic "Template variable unbound in rewrite rule" $
+         vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)
+              , text "Rule" <+> pprRuleName rule_name
+              , text "Rule bndrs:" <+> ppr tmpl_vars
+              , text "LHS args:" <+> ppr tmpl_es
+              , text "Actual args:" <+> ppr target_es ]
+
+
+mk_fake_ty :: InScopeSet -> RuleSubst -> TyVar -> Kind
+-- Roughly:
+--    mk_fake_ty subst tv = Any @(subst (tyVarKind tv))
+-- That is: apply the substitution to the kind of the given tyvar,
+-- and make an 'any' type of that kind.
+-- Tiresomely, the RuleSubst is not well adapted to substTy, leading to
+-- horrible impedence matching.
+--
+-- Happily, this function is seldom called
+mk_fake_ty in_scope (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var1
+  = anyTypeOfKind kind
+  where
+    kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
+                        (tyVarKind tmpl_var1)
+
+    cv_subst = to_co_env id_subst
+
+    to_co_env :: IdSubstEnv -> CvSubstEnv
+    to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env
+      -- It's OK to use nonDetFoldUFM_Directly because we forget the
+      -- order immediately by creating a new env
+
+    to_co uniq expr env
+      = case exprToCoercion_maybe expr of
+          Just co -> extendVarEnv_Directly env uniq co
+          Nothing -> env
 
 {- Note [Unbound RULE binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -631,8 +656,8 @@ bound on the LHS:
   in Trac #13410, and also in test T10602.
 
 
-Note [Template binders]
-~~~~~~~~~~~~~~~~~~~~~~~
+Note [Cloning the template binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following match (example 1):
         Template:  forall x.  f x
         Target:               f (x+1)
@@ -643,21 +668,19 @@ Likewise this one (example 2):
         Template:  forall x. f (\x.x)
         Target:              f (\y.y)
 
-We achieve this simply by:
-  * Adding forall'd template binders to the in-scope set
-
-This works even if the template binder are already in scope
-(in the target) because
+We achieve this simply by using rnBndrL to clone the template
+binders if they are already in scope.
 
-  * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to
-    the target world.  It is not applied recursively.
-
-  * Having the template vars in the in-scope set ensures that in
-    example 2 above, the (\x.x) is cloned to (\x'. x').
-
-In the past we used rnBndrL to clone the template variables if
-they were already in scope.  But (a) that's not necessary and (b)
-it complicate the fancy footwork for Note [Unbound template type variables]
+------ Historical note -------
+At one point I tried simply adding the template binders to the
+in-scope set /without/ cloning them, but that failed in a horribly
+obscure way in Trac #14777.  Problem was that during matching we look
+up target-term variables in the in-scope set (see Note [Lookup
+in-scope]).  If a target-term variable happens to name-clash with a
+template variable, that lookup will find the template variable, which
+is /utterly/ bogus.  In Trac #14777, this transformed a term variable
+into a type variable, and then crashed when we wanted its idInfo.
+------ End of historical note -------
 
 
 ************************************************************************
@@ -673,11 +696,12 @@ it complicate the fancy footwork for Note [Unbound template type variables]
 --   from nested matches; see the Let case of match, below
 --
 data RuleMatchEnv
-  = RV { rv_tmpls :: VarSet          -- Template variables
-       , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
+  = RV { rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
                                      --   (lambda/case)
+       , rv_tmpls :: VarSet          -- Template variables
+                                     --   (after applying envL of rv_lcl)
        , rv_fltR  :: Subst           -- Renamings for floated let-bindings
-                                     --   domain disjoint from envR of rv_lcl
+                                     --   (domain disjoint from envR of rv_lcl)
                                      -- See Note [Matching lets]
        , rv_unf :: IdUnfoldingFun
        }
@@ -707,7 +731,6 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
 --      For a start, in general eta expansion wastes work.
 --      SLPJ July 99
 
-
 match :: RuleMatchEnv
       -> RuleSubst
       -> CoreExpr               -- Template
@@ -738,7 +761,8 @@ match _ _ e@Tick{} _
 -- succeed in matching what looks like the template variable 'a' against 3.
 
 -- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1)    e2 = match_var renv subst v1 e2
+match renv subst (Var v1) e2
+  = match_var renv subst v1 e2
 
 match renv subst e1 (Var v2)      -- Note [Expanding variables]
   | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
@@ -883,7 +907,7 @@ match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
   = do  { subst1 <- match renv' subst r1 r2
         ; match_alts renv subst1 alts1 alts2 }
   where
-    renv' = foldl mb renv (vs1 `zip` vs2)
+    renv' = foldl' mb renv (vs1 `zip` vs2)
     mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2
 
 match_alts _ _ _ _
@@ -1110,19 +1134,19 @@ SpecConstr sees this fragment:
           Data.Maybe.Nothing -> lvl_smf;
           Data.Maybe.Just n_acT [Just S(L)] ->
             case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
-            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+              $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
             }};
 
 and correctly generates the rule
 
         RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
                                           sc_snn :: GHC.Prim.Int#}
-          \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
-          = \$s\$wfoo_sno y_amr sc_snn ;]
+          $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
+          = $s$wfoo_sno y_amr sc_snn ;]
 
 BUT we must ensure that this rule matches in the original function!
-Note that the call to \$wfoo is
-            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+Note that the call to $wfoo is
+            $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
 
 During matching we expand wild_Xf to (Just n_acT).  But then we must also
 expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
@@ -1147,10 +1171,10 @@ is so important.
 -- string for the purposes of error reporting
 ruleCheckProgram :: CompilerPhase               -- ^ Rule activation test
                  -> String                      -- ^ Rule pattern
-                 -> RuleEnv                     -- ^ Database of rules
+                 -> (Id -> [CoreRule])          -- ^ Rules for an Id
                  -> CoreProgram                 -- ^ Bindings to check in
                  -> SDoc                        -- ^ Resulting check message
-ruleCheckProgram phase rule_pat rule_base binds
+ruleCheckProgram phase rule_pat rules binds
   | isEmptyBag results
   = text "Rule check results: no rule application sites"
   | otherwise
@@ -1163,7 +1187,7 @@ ruleCheckProgram phase rule_pat rule_base binds
                        , rc_id_unf    = idUnfolding     -- Not quite right
                                                         -- Should use activeUnfolding
                        , rc_pattern   = rule_pat
-                       , rc_rule_base = rule_base }
+                       , rc_rules = rules }
     results = unionManyBags (map (ruleCheckBind env) binds)
     line = text (replicate 20 '-')
 
@@ -1171,7 +1195,7 @@ data RuleCheckEnv = RuleCheckEnv {
     rc_is_active :: Activation -> Bool,
     rc_id_unf  :: IdUnfoldingFun,
     rc_pattern :: String,
-    rc_rule_base :: RuleEnv
+    rc_rules :: Id -> [CoreRule]
 }
 
 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
@@ -1205,7 +1229,7 @@ ruleCheckFun env fn args
   | null name_match_rules = emptyBag
   | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)
   where
-    name_match_rules = filter match (getRules (rc_rule_base env) fn)
+    name_match_rules = filter match (rc_rules env fn)
     match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index e5af0b8a3c..f6d27ccba5 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -19,6 +19,8 @@ module SpecConstr(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreSubst
 import CoreUtils
@@ -36,7 +38,6 @@ import TyCon            ( tyConName )
 import Id
 import PprCore          ( pprParendExpr )
 import MkCore           ( mkImpossibleExpr )
-import Var
 import VarEnv
 import VarSet
 import Name
@@ -57,9 +58,6 @@ import Control.Monad    ( zipWithM )
 import Data.List
 import PrelNames        ( specTyConName )
 import Module
-
--- See Note [Forcing specialisation]
-
 import TyCon ( TyCon )
 import GHC.Exts( SpecConstrAnnotation(..) )
 import Data.Ord( comparing )
@@ -502,31 +500,46 @@ This is all quite ugly; we ought to come up with a better design.
 
 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
 sc_force to True when calling specLoop. This flag does four things:
+
   * Ignore specConstrThreshold, to specialise functions of arbitrary size
         (see scTopBind)
   * Ignore specConstrCount, to make arbitrary numbers of specialisations
         (see specialise)
   * Specialise even for arguments that are not scrutinised in the loop
-        (see argToPat; Trac #4488)
+        (see argToPat; Trac #4448)
   * Only specialise on recursive types a finite number of times
         (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation])
 
-This flag is inherited for nested non-recursive bindings (which are likely to
-be join points and hence should be fully specialised) but reset for nested
-recursive bindings.
-
-What alternatives did I consider? Annotating the loop itself doesn't
-work because (a) it is local and (b) it will be w/w'ed and having
-w/w propagating annotations somehow doesn't seem like a good idea. The
-types of the loop arguments really seem to be the most persistent
-thing.
-
-Annotating the types that make up the loop state doesn't work,
-either, because (a) it would prevent us from using types like Either
-or tuples here, (b) we don't want to restrict the set of types that
-can be used in Stream states and (c) some types are fixed by the user
-(e.g., the accumulator here) but we still want to specialise as much
-as possible.
+The flag holds only for specialising a single binding group, and NOT
+for nested bindings.  (So really it should be passed around explicitly
+and not stored in ScEnv.)  Trac #14379 turned out to be caused by
+   f SPEC x = let g1 x = ...
+              in ...
+We force-specialise f (because of the SPEC), but that generates a specialised
+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and
+in each copy of g1 we get an unspecialised and specialised copy of g2; and so
+on. Result, exponential.  So the force-spec flag now only applies to one
+level of bindings at a time.
+
+Mechanism for this one-level-only thing:
+
+ - Switch it on at the call to specRec, in scExpr and scTopBinds
+ - Switch it off when doing the RHSs;
+   this can be done very conveniently in decreaseSpecCount
+
+What alternatives did I consider?
+
+* Annotating the loop itself doesn't work because (a) it is local and
+  (b) it will be w/w'ed and having w/w propagating annotations somehow
+  doesn't seem like a good idea. The types of the loop arguments
+  really seem to be the most persistent thing.
+
+* Annotating the types that make up the loop state doesn't work,
+  either, because (a) it would prevent us from using types like Either
+  or tuples here, (b) we don't want to restrict the set of types that
+  can be used in Stream states and (c) some types are fixed by the
+  user (e.g., the accumulator here) but we still want to specialise as
+  much as possible.
 
 Alternatives to ForceSpecConstr
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -586,7 +599,7 @@ more than N times (controlled by -fspec-constr-recursive=N) we check
     specialisations.  If sc_count is "no limit" then we arbitrarily
     choose 10 as the limit (ugh).
 
-See Trac #5550.   Also Trac #13623, where this test had become over-agressive,
+See Trac #5550.   Also Trac #13623, where this test had become over-aggressive,
 and we lost a wonderful specialisation that we really wanted!
 
 Note [NoSpecConstr]
@@ -597,7 +610,7 @@ to mean "don't specialise on arguments of this type".  It was added
 before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
 regardless of size; and then we needed a way to turn that *off*.  Now
 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
-(Used only for PArray.)
+(Used only for PArray, TODO: remove?)
 
 -----------------------------------------------------
                 Stuff not yet handled
@@ -975,7 +988,8 @@ extendCaseBndrs env scrut case_bndr con alt_bndrs
 decreaseSpecCount :: ScEnv -> Int -> ScEnv
 -- See Note [Avoiding exponential blowup]
 decreaseSpecCount env n_specs
-  = env { sc_count = case sc_count env of
+  = env { sc_force = False   -- See Note [Forcing specialisation]
+        , sc_count = case sc_count env of
                        Nothing -> Nothing
                        Just n  -> Just (n `div` (n_specs + 1)) }
         -- The "+1" takes account of the original function;
@@ -1545,7 +1559,11 @@ specRec top_lvl env body_usg rhs_infos
         return (usg_so_far, spec_infos)
 
       | otherwise
-      = do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
+        --                           , text "iteration" <+> int n_iter
+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
+        --                    ]) $
+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
             ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg
                   extra_usg = combineUsages extra_usg_s
                   all_usg   = usg_so_far `combineUsage` extra_usg
@@ -1792,7 +1810,7 @@ that specialisations didn't fire inside wrappers; see test
 simplCore/should_compile/spec-inline.
 
 So now I just use the inline-activation of the parent Id, as the
-activation for the specialiation RULE, just like the main specialiser;
+activation for the specialisation RULE, just like the main specialiser;
 
 This in turn means there is no point in specialising NOINLINE things,
 so we test for that.
@@ -1881,6 +1899,69 @@ by trim_pats.
 
 * Otherwise we sort the patterns to choose the most general
   ones first; more general => more widely applicable.
+
+Note [SpecConstr and casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14270) a call like
+
+    let f = e
+    in ... f (K @(a |> co)) ...
+
+where 'co' is a coercion variable not in scope at f's definition site.
+If we aren't caereful we'll get
+
+    let $sf a co = e (K @(a |> co))
+        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co
+        f = e
+    in ...
+
+But alas, when we match the call we won't bind 'co', because type-matching
+(for good reasons) discards casts).
+
+I don't know how to solve this, so for now I'm just discarding any
+call patterns that
+  * Mentions a coercion variable in a type argument
+  * That is not in scope at the binding of the function
+
+I think this is very rare.
+
+It is important (e.g. Trac #14936) that this /only/ applies to
+coercions mentioned in casts.  We don't want to be discombobulated
+by casts in terms!  For example, consider
+   f ((e1,e2) |> sym co)
+where, say,
+   f  :: Foo -> blah
+   co :: Foo ~R (Int,Int)
+
+Here we definitely do want to specialise for that pair!  We do not
+match on the structre of the coercion; instead we just match on a
+coercion variable, so the RULE looks like
+
+   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)
+     f ((x,y) |> co) = $sf x y co
+
+Often the body of f looks like
+   f arg = ...(case arg |> co' of
+                (x,y) -> blah)...
+
+so that the specialised f will turn into
+   $sf x y co = let arg = (x,y) |> co
+                in ...(case arg>| co' of
+                         (x,y) -> blah)....
+
+which will simplify to not use 'co' at all.  But we can't guarantee
+that co will end up unused, so we still pass it.  Absence analysis
+may remove it later.
+
+Note that this /also/ discards the call pattern if we have a cast in a
+/term/, although in fact Rules.match does make a very flaky and
+fragile attempt to match coercions.  e.g. a call like
+    f (Maybe Age) (Nothing |> co) blah
+    where co :: Maybe Int ~ Maybe Age
+will be discarded.  It's extremely fragile to match on the form of a
+coercion, so I think it's better just not to try.  A more complicated
+alternative would be to discard calls that mention coercion variables
+only in kind-casts, but I'm doing the simple thing for now.
 -}
 
 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
@@ -1918,7 +1999,8 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
                 -- Discard specialisations if there are too many of them
               trimmed_pats = trim_pats env fn spec_info small_pats
 
---        ; pprTrace "callsToPats" (vcat [ text "calls:" <+> ppr calls
+--        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+--                                       , text "done_specs:" <+> ppr (map os_pat done_specs)
 --                                       , text "good_pats:" <+> ppr good_pats ]) $
 --          return ()
 
@@ -1931,7 +2013,8 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
   | sc_force env
     || isNothing mb_scc
     || n_remaining >= n_pats
-  = pats          -- No need to trim
+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
+    pats          -- No need to trim
 
   | otherwise
   = emit_trace $  -- Need to trim, so keep the best ones
@@ -1975,6 +2058,8 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
                                speakNOf spec_count' (text "call pattern") <> comma <+>
                                text "but the limit is" <+> int max_specs) ]
                , text "Use -fspec-constr-count=n to set the bound"
+               , text "done_spec_count =" <+> int done_spec_count
+               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
                , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
 
 
@@ -1983,21 +2068,23 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
         --      Type variables come first, since they may scope
         --      over the following term variables
         -- The [CoreExpr] are the argument patterns for the rule
-callToPats env bndr_occs (Call _ args con_env)
+callToPats env bndr_occs call@(Call _ args con_env)
   | args `ltLength` bndr_occs      -- Check saturated
   = return Nothing
   | otherwise
-  = do  { let in_scope      = substInScope (sc_subst env)
+  = do  { let in_scope = substInScope (sc_subst env)
         ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
-        ; let pat_fvs       = exprsFreeVarsList pats
+        ; let pat_fvs = exprsFreeVarsList pats
                 -- To get determinism we need the list of free variables in
                 -- deterministic order. Otherwise we end up creating
                 -- lambdas with different argument orders. See
                 -- determinism/simplCore/should_compile/spec-inline-determ.hs
                 -- for an example. For explanation of determinism
                 -- considerations See Note [Unique Determinism] in Unique.
+
               in_scope_vars = getInScopeVars in_scope
-              qvars         = filterOut (`elemVarSet` in_scope_vars) pat_fvs
+              is_in_scope v = v `elemVarSet` in_scope_vars
+              qvars         = filterOut is_in_scope pat_fvs
                 -- Quantify over variables that are not in scope
                 -- at the call site
                 -- See Note [Free type variables of the qvar types]
@@ -2012,8 +2099,21 @@ callToPats env bndr_occs (Call _ args con_env)
               sanitise id   = id `setIdType` expandTypeSynonyms (idType id)
                 -- See Note [Free type variables of the qvar types]
 
+              -- Bad coercion variables: see Note [SpecConstr and casts]
+              bad_covars :: CoVarSet
+              bad_covars = mapUnionVarSet get_bad_covars pats
+              get_bad_covars :: CoreArg -> CoVarSet
+              get_bad_covars (Type ty)
+                = filterVarSet (\v -> isId v && not (is_in_scope v)) $
+                  tyCoVarsOfType ty
+              get_bad_covars _
+                = emptyVarSet
+
         ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
-          if interesting
+          WARN( not (isEmptyVarSet bad_covars)
+              , text "SpecConstr: bad covars:" <+> ppr bad_covars
+                $$ ppr call )
+          if interesting && isEmptyVarSet bad_covars
           then return (Just (qvars', pats))
           else return Nothing }
 
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index 869da640ea..6f775dfdcb 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -9,6 +9,8 @@ module Specialise ( specProgram, specUnfolding ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Id
 import TcType hiding( substTy )
 import Type   hiding( substTy, extendTvSubstList )
@@ -43,9 +45,7 @@ import State
 import UniqDFM
 
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 
 {-
 ************************************************************************
@@ -147,7 +147,7 @@ becomes
                          in
                          fl
 
-We still have recusion for non-overloaded functions which we
+We still have recursion for non-overloaded functions which we
 specialise, but the recursive call should get specialised to the
 same recursive version.
 
@@ -735,7 +735,7 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn
   = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))
                             2 (vcat [ text "when specialising" <+> quotes (ppr caller)
                                     | caller <- callers])
-                      , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
+                      , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
                       , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
        ; return ([], []) }
 
@@ -1343,10 +1343,10 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
                         -- See Note [Specialising imported functions] in OccurAnal
 
                   | InlinePragma { inl_inline = Inlinable } <- inl_prag
-                  = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)
+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)
 
                   | otherwise
-                  = (inl_prag, specUnfolding poly_tyvars spec_app
+                  = (inl_prag, specUnfolding dflags poly_tyvars spec_app
                                              arity_decrease fn_unf)
 
                 arity_decrease = length spec_dict_args
@@ -2011,6 +2011,7 @@ mkCallUDs' env f args
             EqPred {}       -> True
             IrredPred {}    -> True   -- Things like (D []) where D is a
                                       -- Constraint-ranged family; Trac #7785
+            ForAllPred {}   -> True
 
 {-
 Note [Type determines value]
@@ -2095,7 +2096,7 @@ mkDB bind = (bind, bind_fvs bind)
 -- | Identify the free variables of a 'CoreBind'
 bind_fvs :: CoreBind -> VarSet
 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
-bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
+bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs
                            where
                              bndrs = map fst prs
                              rhs_fvs = unionVarSets (map pair_fvs prs)
@@ -2287,12 +2288,10 @@ instance Monad SpecM where
                                case f y of
                                    SpecM z ->
                                        z
-    fail str = SpecM $ fail str
+    fail = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail SpecM where
     fail str = SpecM $ fail str
-#endif
 
 instance MonadUnique SpecM where
     getUniqueSupplyM
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 900d23f7b5..fdd8d5bef3 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -11,12 +11,15 @@
 -- And, as we have the info in hand, we may convert some lets to
 -- let-no-escapes.
 
-module CoreToStg ( coreToStg, coreExprToStg ) where
+module CoreToStg ( coreToStg ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
-import CoreUtils        ( exprType, findDefault, isJoinBind )
+import CoreUtils        ( exprType, findDefault, isJoinBind
+                        , exprIsTickedString_maybe )
 import CoreArity        ( manifestArity )
 import StgSyn
 
@@ -27,10 +30,10 @@ import MkId             ( coercionTokenId )
 import Id
 import IdInfo
 import DataCon
-import CostCentre       ( noCCS )
+import CostCentre
 import VarEnv
 import Module
-import Name             ( isExternalName, nameOccName )
+import Name             ( isExternalName, nameOccName, nameModule_maybe )
 import OccName          ( occNameFS )
 import BasicTypes       ( Arity )
 import TysWiredIn       ( unboxedUnitDataCon )
@@ -44,7 +47,9 @@ import ForeignCall
 import Demand           ( isUsedOnce )
 import PrimOp           ( PrimCall(..) )
 import UniqFM
+import SrcLoc           ( mkGeneralSrcSpan )
 
+import Data.List.NonEmpty (nonEmpty, toList)
 import Data.Maybe    (isJust, fromMaybe)
 import Control.Monad (liftM, ap)
 
@@ -126,15 +131,6 @@ import Control.Monad (liftM, ap)
 --
 -- The CafInfo has already been calculated during the CoreTidy pass.
 --
--- During CoreToStg, we then pin onto each binding and case expression, a
--- list of Ids which represents the "live" CAFs at that point.  The meaning
--- of "live" here is the same as for live variables, see above (which is
--- why it's convenient to collect CAF information here rather than elsewhere).
---
--- The later SRT pass takes these lists of Ids and uses them to construct
--- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
--- pairs.
-
 -- Note [What is a non-escaping let]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
@@ -194,61 +190,99 @@ import Control.Monad (liftM, ap)
 --     in
 --         ...(x b)...
 
+-- Note [Cost-centre initialization plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
+-- and the fields were then fixed by a seperate pass `stgMassageForProfiling`.
+-- We now initialize these correctly. The initialization works like this:
+--
+--   - For non-top level bindings always use `currentCCS`.
+--
+--   - For top-level bindings, check if the binding is a CAF
+--
+--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
+--                 and use it. Note that these new cost centres need to be
+--                 collected to be able to generate cost centre initialization
+--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
+--
+--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
+--
+--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
+--                 do we set CCCS from it; so we just slam in
+--                 dontCareCostCentre.
+
 -- --------------------------------------------------------------
 -- Setting variable info: top-level, binds, RHSs
 -- --------------------------------------------------------------
 
-coreToStg :: DynFlags -> Module -> CoreProgram -> [StgTopBinding]
+coreToStg :: DynFlags -> Module -> CoreProgram
+          -> ([StgTopBinding], CollectedCCs)
 coreToStg dflags this_mod pgm
-  = pgm'
-  where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
+  = (pgm', final_ccs)
+  where
+    (_, _, (local_ccs, local_cc_stacks), pgm')
+      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+
+    prof = WayProf `elem` ways dflags
 
-coreExprToStg :: CoreExpr -> StgExpr
-coreExprToStg expr
-  = new_expr where (new_expr,_) = initCts emptyVarEnv (coreToStgExpr expr)
+    final_ccs
+      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
+      | prof
+      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
+      | otherwise
+      = emptyCollectedCCs
 
+    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
 
 coreTopBindsToStg
     :: DynFlags
     -> Module
     -> IdEnv HowBound           -- environment for the bindings
+    -> CollectedCCs
     -> CoreProgram
-    -> (IdEnv HowBound, FreeVarsInfo, [StgTopBinding])
+    -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, [StgTopBinding])
 
-coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg dflags this_mod env (b:bs)
-  = (env2, fvs2, b':bs')
+coreTopBindsToStg _      _        env ccs []
+  = (env, emptyFVInfo, ccs, [])
+coreTopBindsToStg dflags this_mod env ccs (b:bs)
+  = (env2, fvs2, ccs2, b':bs')
   where
         -- Notice the mutually-recursive "knot" here:
         --   env accumulates down the list of binds,
         --   fvs accumulates upwards
-        (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
-        (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
+        (env1, fvs2, ccs1, b' ) =
+          coreTopBindToStg dflags this_mod env fvs1 ccs b
+        (env2, fvs1, ccs2, bs') =
+          coreTopBindsToStg dflags this_mod env1 ccs1 bs
 
 coreTopBindToStg
         :: DynFlags
         -> Module
         -> IdEnv HowBound
         -> FreeVarsInfo         -- Info about the body
+        -> CollectedCCs
         -> CoreBind
-        -> (IdEnv HowBound, FreeVarsInfo, StgTopBinding)
+        -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, StgTopBinding)
 
-coreTopBindToStg _ _ env body_fvs (NonRec id (Lit (MachStr str)))
+coreTopBindToStg _ _ env body_fvs ccs (NonRec id e)
+  | Just str <- exprIsTickedString_maybe e
   -- top-level string literal
+  -- See Note [CoreSyn top-level string literals] in CoreSyn
   = let
         env' = extendVarEnv env id how_bound
         how_bound = LetBound TopLet 0
-    in (env', body_fvs, StgTopStringLit id str)
+    in (env', body_fvs, ccs, StgTopStringLit id str)
 
-coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
+coreTopBindToStg dflags this_mod env body_fvs ccs (NonRec id rhs)
   = let
         env'      = extendVarEnv env id how_bound
         how_bound = LetBound TopLet $! manifestArity rhs
 
-        (stg_rhs, fvs') =
-            initCts env $ do
-              (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
-              return (stg_rhs, fvs')
+        (stg_rhs, fvs', ccs') =
+            initCts env $
+              coreToTopStgRhs dflags ccs this_mod body_fvs (id,rhs)
 
         bind = StgTopLifted $ StgNonRec id stg_rhs
     in
@@ -257,9 +291,9 @@ coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
       --     as well as 'id', but that led to a black hole
       --     where printing the assertion error tripped the
       --     assertion again!
-    (env', fvs' `unionFVInfo` body_fvs, bind)
+    (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
 
-coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
+coreTopBindToStg dflags this_mod env body_fvs ccs (Rec pairs)
   = ASSERT( not (null pairs) )
     let
         binders = map fst pairs
@@ -268,16 +302,21 @@ coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
                      | (b, rhs) <- pairs ]
         env' = extendVarEnvList env extra_env'
 
-        (stg_rhss, fvs')
+        -- generate StgTopBindings, accumulate body_fvs and CAF cost centres
+        -- created for CAFs
+        ((fvs', ccs'), stg_rhss)
           = initCts env' $ do
-               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
-               let fvs' = unionFVInfos fvss'
-               return (stg_rhss, fvs')
+               mapAccumLM (\(fvs, ccs) rhs -> do
+                            (rhs', fvs', ccs') <-
+                              coreToTopStgRhs dflags ccs this_mod body_fvs rhs
+                            return ((fvs' `unionFVInfo` fvs, ccs'), rhs'))
+                          (body_fvs, ccs)
+                          pairs
 
         bind = StgTopLifted $ StgRec (zip binders stg_rhss)
     in
     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
-    (env', fvs' `unionFVInfo` body_fvs, bind)
+    (env', fvs' `unionFVInfo` body_fvs, ccs', bind)
 
 
 -- Assertion helper: this checks that the CafInfo on the Id matches
@@ -297,18 +336,23 @@ consistentCafInfo id bind
 
 coreToTopStgRhs
         :: DynFlags
+        -> CollectedCCs
         -> Module
         -> FreeVarsInfo         -- Free var info for the scope of the binding
         -> (Id,CoreExpr)
-        -> CtsM (StgRhs, FreeVarsInfo)
+        -> CtsM (StgRhs, FreeVarsInfo, CollectedCCs)
 
-coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
+coreToTopStgRhs dflags ccs this_mod scope_fv_info (bndr, rhs)
   = do { (new_rhs, rhs_fvs) <- coreToStgExpr rhs
 
-       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
-             stg_arity = stgRhsArity stg_rhs
+       ; let (stg_rhs, ccs') =
+               mkTopStgRhs dflags this_mod ccs rhs_fvs bndr bndr_info new_rhs
+             stg_arity =
+               stgRhsArity stg_rhs
+
        ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
-                 rhs_fvs) }
+                 rhs_fvs,
+                 ccs') }
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
 
@@ -331,14 +375,6 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
                 text "Id arity:" <+> ppr id_arity,
                 text "STG arity:" <+> ppr stg_arity]
 
-mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-            -> Id -> StgBinderInfo -> StgExpr
-            -> StgRhs
-
-mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
-        -- Dynamic StgConApps are updatable
-  where con_updateable con args = isDllConApp dflags this_mod con args
-
 -- ---------------------------------------------------------------------------
 -- Expressions
 -- ---------------------------------------------------------------------------
@@ -354,9 +390,10 @@ coreToStgExpr
 -- on these components, but it in turn is not scrutinised as the basis for any
 -- decisions.  Hence no black holes.
 
--- No LitInteger's should be left by the time this is called. CorePrep
--- should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
+-- No LitInteger's or LitNatural's should be left by the time this is called.
+-- CorePrep should have converted them all to a real core representation.
+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
 coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo)
 coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
 coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
@@ -374,9 +411,10 @@ coreToStgExpr expr@(Lam _ _)
     extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
     (body, body_fvs) <- coreToStgExpr body
     let
-        fvs             = args' `minusFVBinders` body_fvs
-        result_expr | null args' = body
-                    | otherwise  = StgLam args' body
+        fvs         = args' `minusFVBinders` body_fvs
+        result_expr = case nonEmpty args' of
+          Nothing     -> body
+          Just args'' -> StgLam args'' body
 
     return (result_expr, fvs)
 
@@ -718,36 +756,85 @@ coreToStgRhs scope_fv_info (bndr, rhs) = do
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
 
-mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs = mkStgRhs' con_updateable
-  where con_updateable _ _ = False
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
+            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr
+            -> (StgRhs, CollectedCCs)
 
-mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
-            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
+mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
   | StgLam bndrs body <- rhs
-  = StgRhsClosure noCCS binder_info
-                   (getFVs rhs_fvs)
-                   ReEntrant
-                   bndrs body
-  | isJoinId bndr -- must be nullary join point
-  = ASSERT(idJoinArity bndr == 0)
-    StgRhsClosure noCCS binder_info
-                   (getFVs rhs_fvs)
-                   ReEntrant -- ignored for LNE
-                   [] rhs
+  = -- StgLam can't have empty arguments, so not CAF
+    ( StgRhsClosure dontCareCCS binder_info
+                    (getFVs rhs_fvs)
+                    ReEntrant
+                    (toList bndrs) body
+    , ccs )
+
   | StgConApp con args _ <- unticked_rhs
-  , not (con_updateable con args)
+  , -- Dynamic StgConApps are updatable
+    not (isDllConApp dflags this_mod con args)
   = -- CorePrep does this right, but just to make sure
     ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
            , ppr bndr $$ ppr con $$ ppr args)
-    StgRhsCon noCCS con args
+    ( StgRhsCon dontCareCCS con args, ccs )
+
+  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+  | gopt Opt_AutoSccsOnIndividualCafs dflags
+  = ( StgRhsClosure caf_ccs binder_info
+                    (getFVs rhs_fvs)
+                    upd_flag [] rhs
+    , collectCC caf_cc caf_ccs ccs )
+
   | otherwise
-  = StgRhsClosure noCCS binder_info
-                   (getFVs rhs_fvs)
-                   upd_flag [] rhs
- where
+  = ( StgRhsClosure all_cafs_ccs binder_info
+                    (getFVs rhs_fvs)
+                    upd_flag [] rhs
+    , ccs )
+
+  where
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+    -- CAF cost centres generated for -fcaf-all
+    caf_cc = mkAutoCC bndr modl
+    caf_ccs = mkSingletonCCS caf_cc
+           -- careful: the binder might be :Main.main,
+           -- which doesn't belong to module mod_name.
+           -- bug #249, tests prof001, prof002
+    modl | Just m <- nameModule_maybe (idName bndr) = m
+         | otherwise = this_mod
+
+    -- default CAF cost centre
+    (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialzation plan].
+mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs rhs_fvs bndr binder_info rhs
+  | StgLam bndrs body <- rhs
+  = StgRhsClosure currentCCS binder_info
+                  (getFVs rhs_fvs)
+                  ReEntrant
+                  (toList bndrs) body
+
+  | isJoinId bndr -- must be a nullary join point
+  = ASSERT(idJoinArity bndr == 0)
+    StgRhsClosure currentCCS binder_info
+                  (getFVs rhs_fvs)
+                  ReEntrant -- ignored for LNE
+                  [] rhs
+
+  | StgConApp con args _ <- unticked_rhs
+  = StgRhsCon currentCCS con args
 
+  | otherwise
+  = StgRhsClosure currentCCS binder_info
+                  (getFVs rhs_fvs)
+                  upd_flag [] rhs
+  where
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
@@ -903,6 +990,14 @@ lookupBinding env v = case lookupVarEnv env v of
                         Just xx -> xx
                         Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
 
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+    let
+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+      all_cafs_cc  = mkAllCafsCC this_mod span
+      all_cafs_ccs = mkSingletonCCS all_cafs_cc
+    in
+      (all_cafs_cc, all_cafs_ccs)
 
 -- ---------------------------------------------------------------------------
 -- Free variable information
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index cbfd11b8d9..58f14a1b3f 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -1,74 +1,80 @@
-{-
+{- |
 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 
-\section[StgLint]{A ``lint'' pass to check for Stg correctness}
--}
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+  appear in case), except when they're join points (see Note [CoreSyn let/app
+  invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+  invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
 
-{-# LANGUAGE CPP #-}
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+    WARNING:
+    ~~~~~~~~
+
+    This module has suffered bit-rot; it is likely to yield lint errors
+    for Stg code that is currently perfectly acceptable for code
+    generation.  Solution: don't use it!  (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
 
 module StgLint ( lintStgTopBindings ) where
 
+import GhcPrelude
+
 import StgSyn
 
+import DynFlags
 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
-import Id               ( Id, idType, isLocalId )
+import Id               ( Id, idType, isLocalId, isJoinId )
 import VarSet
 import DataCon
 import CoreSyn          ( AltCon(..) )
-import PrimOp           ( primOpType )
-import Literal          ( literalType )
-import Maybes
 import Name             ( getSrcLoc )
 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
 import Type
 import RepType
-import TyCon
-import Util
 import SrcLoc
 import Outputable
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
 import Control.Monad
 
-#include "HsVersions.h"
-
-{-
-Checks for
-        (a) *some* type errors
-        (b) locally-defined variables used but not defined
-
-
-Note: unless -dverbose-stg is on, display of lint errors will result
-in "panic: bOGUS_LVs".
-
-WARNING:
-~~~~~~~~
-
-This module has suffered bit-rot; it is likely to yield lint errors
-for Stg code that is currently perfectly acceptable for code
-generation.  Solution: don't use it!  (KSW 2000-05).
-
-
-************************************************************************
-*                                                                      *
-\subsection{``lint'' for various constructs}
-*                                                                      *
-************************************************************************
-
-@lintStgTopBindings@ is the top-level interface function.
--}
+lintStgTopBindings :: DynFlags
+                   -> Bool   -- ^ have we run Unarise yet?
+                   -> String -- ^ who produced the STG?
+                   -> [StgTopBinding]
+                   -> IO ()
 
-lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding]
-
-lintStgTopBindings whodunnit binds
+lintStgTopBindings dflags unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case (initL (lint_binds binds)) of
-      Nothing  -> binds
-      Just msg -> pprPanic "" (vcat [
-                        text "*** Stg Lint ErrMsgs: in" <+>
-                              text whodunnit <+> text "***",
-                        msg,
-                        text "*** Offending Program ***",
-                        pprStgTopBindings binds,
-                        text "*** End of Offense ***"])
+    case initL unarised (lint_binds binds) of
+      Nothing  ->
+        return ()
+      Just msg -> do
+        putLogMsg dflags NoReason Err.SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+                        text whodunnit <+> text "***",
+                  msg,
+                  text "*** Offending Program ***",
+                  pprStgTopBindings binds,
+                  text "*** End of Offense ***"])
+        Err.ghcExit dflags 1
   where
     lint_binds :: [StgTopBinding] -> LintM ()
 
@@ -81,13 +87,12 @@ lintStgTopBindings whodunnit binds
     lint_bind (StgTopLifted bind) = lintStgBinds bind
     lint_bind (StgTopStringLit v _) = return [v]
 
-lintStgArg :: StgArg -> LintM (Maybe Type)
-lintStgArg (StgLitArg lit) = return (Just (literalType lit))
-lintStgArg (StgVarArg v)   = lintStgVar v
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
 
-lintStgVar :: Id -> LintM (Maybe Kind)
-lintStgVar v = do checkInScope v
-                  return (Just (idType v))
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
 
 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
 lintStgBinds (StgNonRec binder rhs) = do
@@ -104,80 +109,50 @@ lintStgBinds (StgRec pairs)
 lint_binds_help :: (Id, StgRhs) -> LintM ()
 lint_binds_help (binder, rhs)
   = addLoc (RhsOf binder) $ do
-        -- Check the rhs
-        _maybe_rhs_ty <- lintStgRhs rhs
-
-        -- Check binder doesn't have unlifted type
-        checkL (not (isUnliftedType binder_ty))
+        lintStgRhs rhs
+        -- Check binder doesn't have unlifted type or it's a join point
+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
                (mkUnliftedTyMsg binder rhs)
 
-        -- Check match to RHS type
-        -- Actually we *can't* check the RHS type, because
-        -- unsafeCoerce means it really might not match at all
-        -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...
-        -- case maybe_rhs_ty of
-        --  Nothing     -> return ()
-        --    Just rhs_ty -> checkTys binder_ty
-        --                          rhs_ty
-        ---                         (mkRhsMsg binder rhs_ty)
-
-        return ()
-  where
-    binder_ty = idType binder
-
-lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
+lintStgRhs :: StgRhs -> LintM ()
 
 lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
   = lintStgExpr expr
 
 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) $
-      addInScopeVars binders $ runMaybeT $ do
-        body_ty <- MaybeT $ lintStgExpr expr
-        return (mkFunTys (map idType binders) body_ty)
+      addInScopeVars binders $
+        lintStgExpr expr
 
 lintStgRhs rhs@(StgRhsCon _ con args) = do
-    -- TODO: Check arg_tys
     when (isUnboxedTupleCon con || isUnboxedSumCon con) $
       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
                ppr rhs)
-    runMaybeT $ do
-      arg_tys <- mapM (MaybeT . lintStgArg) args
-      MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
-  where
-    con_ty = dataConRepType con
-
-lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
 
-lintStgExpr (StgLit l) = return (Just (literalType l))
+lintStgExpr :: StgExpr -> LintM ()
 
-lintStgExpr e@(StgApp fun args) = runMaybeT $ do
-    fun_ty <- MaybeT $ lintStgVar fun
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
+lintStgExpr (StgLit _) = return ()
 
-lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do
-    -- TODO: Check arg_tys
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
-  where
-    con_ty = dataConRepType con
+lintStgExpr (StgApp fun args) = do
+    lintStgVar fun
+    mapM_ lintStgArg args
 
-lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
-  where
-    op_ty = primOpType op
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+    -- unboxed sums should vanish during unarise
+    lf <- getLintFlags
+    when (lf_unarised lf && isUnboxedSumCon con) $
+      addErrL (text "Unboxed sum after unarise:" $$
+               ppr app)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
 
-lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do
-        -- We don't have enough type information to check
-        -- the application for StgFCallOp and StgPrimCallOp; ToDo
-    _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
-    return res_ty
+lintStgExpr (StgOpApp _ args _) =
+    mapM_ lintStgArg args
 
-lintStgExpr (StgLam bndrs _) = do
-    addErrL (text "Unexpected StgLam" <+> ppr bndrs)
-    return Nothing
+lintStgExpr lam@(StgLam _ _) =
+    addErrL (text "Unexpected StgLam" <+> ppr lam)
 
 lintStgExpr (StgLet binds body) = do
     binders <- lintStgBinds binds
@@ -193,78 +168,25 @@ lintStgExpr (StgLetNoEscape binds body) = do
 
 lintStgExpr (StgTick _ expr) = lintStgExpr expr
 
-lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
-    _ <- MaybeT $ lintStgExpr scrut
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+    lintStgExpr scrut
 
-    in_scope <- MaybeT $ liftM Just $
-     case alts_type of
-        AlgAlt tc     -> check_bndr (tyConPrimRep tc) >> return True
-        PrimAlt rep   -> check_bndr [rep]             >> return True
-        MultiValAlt _ -> return False -- Binder is always dead in this case
-        PolyAlt       -> return True
+    lf <- getLintFlags
+    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
 
-    MaybeT $ addInScopeVars [bndr | in_scope] $
-             lintStgAlts alts scrut_ty
-  where
-    scrut_ty        = idType bndr
-    scrut_reps      = typePrimRep scrut_ty
-    check_bndr reps = checkL (scrut_reps == reps) bad_bndr
-                  where
-                     bad_bndr = mkDefltMsg bndr reps
-
-lintStgAlts :: [StgAlt]
-            -> Type               -- Type of scrutinee
-            -> LintM (Maybe Type) -- Just ty => type is accurage
-
-lintStgAlts alts scrut_ty = do
-    maybe_result_tys <- mapM (lintAlt scrut_ty) alts
-
-    -- Check the result types
-    case catMaybes (maybe_result_tys) of
-      []             -> return Nothing
-
-      (first_ty:_tys) -> do -- mapM_ check tys
-                           return (Just first_ty)
-        where
-          -- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-          -- We can't check that the alternatives have the
-          -- same type, because they don't, with unsafeCoerce#
-
-lintAlt :: Type -> (AltCon, [Id], StgExpr) -> LintM (Maybe Type)
-lintAlt _ (DEFAULT, _, rhs)
- = lintStgExpr rhs
-
-lintAlt scrut_ty (LitAlt lit, _, rhs) = do
-   checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
-   lintStgExpr rhs
-
-lintAlt scrut_ty (DataAlt con, args, rhs) = do
-    case splitTyConApp_maybe scrut_ty of
-      Just (tycon, tys_applied) | isAlgTyCon tycon &&
-                                  not (isNewTyCon tycon) -> do
-         let
-           cons    = tyConDataCons tycon
-           arg_tys = dataConInstArgTys con tys_applied
-                -- This does not work for existential constructors
-
-         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
-         checkL (args `lengthIs` dataConRepArity con) (mkAlgAltMsg3 con args)
-         when (isVanillaDataCon con) $
-           mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
-         return ()
-      _ ->
-         addErrL (mkAltMsg1 scrut_ty)
-
-    addInScopeVars args $
-         lintStgExpr rhs
-  where
-    check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
+    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+    lintStgExpr rhs
 
-    -- elem: yes, the elem-list here can sometimes be long-ish,
-    -- but as it's use-once, probably not worth doing anything different
-    -- We give it its own copy, so it isn't overloaded.
-    elem _ []       = False
-    elem x (y:ys)   = x==y || elem x ys
+lintAlt (LitAlt _, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+    mapM_ checkPostUnariseBndr bndrs
+    addInScopeVars bndrs (lintStgExpr rhs)
 
 {-
 ************************************************************************
@@ -275,12 +197,17 @@ lintAlt scrut_ty (DataAlt con, args, rhs) = do
 -}
 
 newtype LintM a = LintM
-    { unLintM :: [LintLocInfo]      -- Locations
+    { unLintM :: LintFlags
+              -> [LintLocInfo]      -- Locations
               -> IdSet              -- Local vars in scope
               -> Bag MsgDoc        -- Error messages so far
               -> (a, Bag MsgDoc)   -- Result and error messages (if any)
     }
 
+data LintFlags = LintFlags { lf_unarised :: !Bool
+                             -- ^ have we run the unariser yet?
+                           }
+
 data LintLocInfo
   = RhsOf Id            -- The variable bound
   | LambdaBodyOf [Id]   -- The lambda-binder
@@ -303,20 +230,22 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: LintM a -> Maybe MsgDoc
-initL (LintM m)
-  = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
+initL :: Bool -> LintM a -> Maybe MsgDoc
+initL unarised (LintM m)
+  = case (m lf [] emptyVarSet emptyBag) of { (_, errs) ->
     if isEmptyBag errs then
         Nothing
     else
         Just (vcat (punctuate blankLine (bagToList errs)))
     }
+  where
+    lf = LintFlags unarised
 
 instance Functor LintM where
       fmap = liftM
 
 instance Applicative LintM where
-      pure a = LintM $ \_loc _scope errs -> (a, errs)
+      pure a = LintM $ \_lf _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -325,21 +254,59 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \loc scope errs
-  -> case unLintM m loc scope errs of
-      (r, errs') -> unLintM (k r) loc scope errs'
+thenL m k = LintM $ \lf loc scope errs
+  -> case unLintM m lf loc scope errs of
+      (r, errs') -> unLintM (k r) lf loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \loc scope errs
-  -> case unLintM m loc scope errs of
-      (_, errs') -> unLintM k loc scope errs'
+thenL_ m k = LintM $ \lf loc scope errs
+  -> case unLintM m lf loc scope errs of
+      (_, errs') -> unLintM k lf loc scope errs'
 
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
 checkL False msg = addErrL msg
 
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+    lf <- getLintFlags
+    when (lf_unarised lf) $
+      forM_ (checkPostUnariseId bndr) $ \unexpected ->
+        addErrL $
+          text "After unarisation, binder " <>
+          ppr bndr <> text " has " <> text unexpected <> text " type " <>
+          ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+    StgLitArg _ ->
+      return ()
+    StgVarArg id -> do
+      lf <- getLintFlags
+      when (lf_unarised lf) $
+        forM_ (checkPostUnariseId id) $ \unexpected ->
+          addErrL $
+            text "After unarisation, arg " <>
+            ppr id <> text " has " <> text unexpected <> text " type " <>
+            ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+    let
+      id_ty = idType id
+      is_sum, is_tuple, is_void :: Maybe String
+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+      is_void = guard (isVoidTy id_ty) >> return "void"
+    in
+      is_sum <|> is_tuple <|> is_void
+
 addErrL :: MsgDoc -> LintM ()
-addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
 
 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
 addErr errs_so_far msg locs
@@ -350,185 +317,26 @@ addErr errs_so_far msg locs
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \loc scope errs
-   -> unLintM m (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \lf loc scope errs
+   -> unLintM m lf (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \loc scope errs
+addInScopeVars ids m = LintM $ \lf loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m loc (scope `unionVarSet` new_set) errs
-
-{-
-Checking function applications: we only check that the type has the
-right *number* of arrows, we don't actually compare the types.  This
-is because we can't expect the types to be equal - the type
-applications and type lambdas that we use to calculate accurate types
-have long since disappeared.
--}
+    in unLintM m lf loc (scope `unionVarSet` new_set) errs
 
-checkFunApp :: Type                 -- The function type
-            -> [Type]               -- The arg type(s)
-            -> MsgDoc               -- Error message
-            -> LintM (Maybe Type)   -- Just ty => result type is accurate
-
-checkFunApp fun_ty arg_tys msg
- = do { case mb_msg of
-          Just msg -> addErrL msg
-          Nothing  -> return ()
-      ; return mb_ty }
- where
-  (mb_ty, mb_msg) = cfa True fun_ty arg_tys
-
-  cfa :: Bool -> Type -> [Type] -> (Maybe Type          -- Accurate result?
-                                   , Maybe MsgDoc)      -- Errors?
-
-  cfa accurate fun_ty []      -- Args have run out; that's fine
-      = (if accurate then Just fun_ty else Nothing, Nothing)
-
-  cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
-      | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-      = if accurate && not (arg_ty `stgEqType` arg_ty')
-        then (Nothing, Just msg)       -- Arg type mismatch
-        else cfa accurate res_ty arg_tys'
-
-      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
-      = cfa False fun_ty' arg_tys
-
-      | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
-      , isNewTyCon tc
-      = if tc_args `lengthLessThan` tyConArity tc
-        then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
-             (Nothing, Nothing)   -- This is odd, but I've seen it
-        else cfa False (newTyConInstRhs tc tc_args) arg_tys
-
-      | Just tc <- tyConAppTyCon_maybe fun_ty
-      , not (isTypeFamilyTyCon tc)      -- Definite error
-      = (Nothing, Just msg)             -- Too many args
-
-      | otherwise
-      = (Nothing, Nothing)
-
-stgEqType :: Type -> Type -> Bool
--- Compare types, but crudely because we have discarded
--- both casts and type applications, so types might look
--- different but be the same.  So reply "True" if in doubt.
--- "False" means that the types are definitely different.
---
--- Fundamentally this is a losing battle because of unsafeCoerce
-
-stgEqType orig_ty1 orig_ty2
-  = gos orig_ty1 orig_ty2
-  where
-    gos :: Type -> Type -> Bool
-    gos ty1   ty2
-        -- These have no prim rep
-      | isRuntimeRepKindedTy ty1 && isRuntimeRepKindedTy ty2
-      = True
-
-        -- We have a unary type
-      | [_] <- reps1, [_] <- reps2
-      = go ty1 ty2
-
-        -- In the case of a tuple just compare prim reps
-      | otherwise
-      = reps1 == reps2
-      where
-        reps1 = typePrimRep ty1
-        reps2 = typePrimRep ty2
-
-    go :: UnaryType -> UnaryType -> Bool
-    go ty1 ty2
-      | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
-      , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
-      , let res = if tc1 == tc2
-                  then equalLength tc_args1 tc_args2
-                       && and (zipWith gos tc_args1 tc_args2)
-                  else  -- TyCons don't match; but don't bleat if either is a
-                        -- family TyCon because a coercion might have made it
-                        -- equal to something else
-                    (isFamilyTyCon tc1 || isFamilyTyCon tc2)
-      = if res then True
-        else
-        pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2])
-        False
-
-      | otherwise = True  -- Conservatively say "fine".
-                          -- Type variables in particular
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \loc scope errs
+checkInScope id = LintM $ \_lf loc scope errs
  -> if isLocalId id && not (id `elemVarSet` scope) then
-        ((), addErr errs (hsep [ppr id, text "is out of scope"]) loc)
+        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+                                text "is out of scope"]) loc)
     else
         ((), errs)
 
-checkTys :: Type -> Type -> MsgDoc -> LintM ()
-checkTys ty1 ty2 msg = LintM $ \loc _scope errs
-  -> if (ty1 `stgEqType` ty2)
-     then ((), errs)
-     else ((), addErr errs msg loc)
-
-_mkCaseAltMsg :: [StgAlt] -> MsgDoc
-_mkCaseAltMsg _alts
-  = ($$) (text "In some case alternatives, type of alternatives not all same:")
-            (Outputable.empty) -- LATER: ppr alts
-
-mkDefltMsg :: Id -> [PrimRep] -> MsgDoc
-mkDefltMsg bndr reps
-  = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")
-         (ppr bndr $$ ppr (idType bndr) $$ ppr reps)
-
-mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
-mkFunAppMsg fun_ty arg_tys expr
-  = vcat [text "In a function application, function type doesn't match arg types:",
-              hang (text "Function type:") 4 (ppr fun_ty),
-              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)),
-              hang (text "Expression:") 4 (ppr expr)]
-
-mkRhsConMsg :: Type -> [Type] -> MsgDoc
-mkRhsConMsg fun_ty arg_tys
-  = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
-              hang (text "Constructor type:") 4 (ppr fun_ty),
-              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))]
-
-mkAltMsg1 :: Type -> MsgDoc
-mkAltMsg1 ty
-  = ($$) (text "In a case expression, type of scrutinee does not match patterns")
-         (ppr ty)
-
-mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc
-mkAlgAltMsg2 ty con
-  = vcat [
-        text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
-        ppr ty,
-        ppr con
-    ]
-
-mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc
-mkAlgAltMsg3 con alts
-  = vcat [
-        text "In some algebraic case alternative, number of arguments doesn't match constructor:",
-        ppr con,
-        ppr alts
-    ]
-
-mkAlgAltMsg4 :: Type -> Id -> MsgDoc
-mkAlgAltMsg4 ty arg
-  = vcat [
-        text "In some algebraic case alternative, type of argument doesn't match data constructor:",
-        ppr ty,
-        ppr arg
-    ]
-
-_mkRhsMsg :: Id -> Type -> MsgDoc
-_mkRhsMsg binder ty
-  = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:",
-                     ppr binder],
-              hsep [text "Binder's type:", ppr (idType binder)],
-              hsep [text "Rhs type:", ppr ty]
-             ]
-
 mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
 mkUnliftedTyMsg binder rhs
   = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 15181f3e5d..eb905f7456 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -39,12 +39,15 @@ module StgSyn (
         isDllConApp,
         stgArgType,
         stripStgTicksTop,
+        stgCaseBndrInScope,
 
         pprStgBinding, pprStgTopBindings
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn     ( AltCon, Tickish )
 import CostCentre  ( CostCentreStack )
 import Data.ByteString ( ByteString )
@@ -68,6 +71,8 @@ import RepType     ( typePrimRep1 )
 import Unique      ( Unique )
 import Util
 
+import Data.List.NonEmpty ( NonEmpty, toList )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -151,6 +156,18 @@ stripStgTicksTop p = go []
    where go ts (StgTick t e) | p t = go (t:ts) e
          go ts other               = (reverse ts, other)
 
+-- | Given an alt type and whether the program is unarised, return whether the
+-- case binder is in scope.
+--
+-- Case binders of unboxed tuple or unboxed sum type always dead after the
+-- unariser has run. See Note [Post-unarisation invariants].
+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
+stgCaseBndrInScope alt_ty unarised =
+    case alt_ty of
+      AlgAlt _      -> True
+      PrimAlt _     -> True
+      MultiValAlt _ -> not unarised
+      PolyAlt       -> True
 
 {-
 ************************************************************************
@@ -219,7 +236,7 @@ finished it encodes (\x -> e) as (let f = \x -> e in f)
 -}
 
   | StgLam
-        [bndr]
+        (NonEmpty bndr)
         StgExpr    -- Body of lambda
 
 {-
@@ -547,6 +564,7 @@ data AltType
   = PolyAlt             -- Polymorphic (a lifted type variable)
   | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
                         -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
   | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
   | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
 
@@ -665,8 +683,8 @@ pprGenStgBinding (StgNonRec bndr rhs)
         4 (ppr rhs <> semi)
 
 pprGenStgBinding (StgRec pairs)
-  = vcat $ ifPprDebug (text "{- StgRec (begin) -}") :
-           map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")]
+  = vcat $ whenPprDebug (text "{- StgRec (begin) -}") :
+           map (ppr_bind) pairs ++ [whenPprDebug (text "{- StgRec (end) -}")]
   where
     ppr_bind (bndr, expr)
       = hang (hsep [pprBndr LetBind bndr, equals])
@@ -718,7 +736,7 @@ pprStgExpr (StgOpApp op args _)
   = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam bndrs body)
-  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
             <+> text "->",
          pprStgExpr body ]
   where ppr_list = brackets . fsep . punctuate comma
@@ -738,7 +756,7 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a
       (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
                           ppr cc,
                           pp_binder_info bi,
-                          text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
+                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),
                           ppr upd_flag, text " [",
                           interppSP args, char ']'])
             8 (sep [hsep [ppr rhs, text "} in"]]))
@@ -774,7 +792,7 @@ pprStgExpr (StgTick tickish expr)
 pprStgExpr (StgCase expr bndr alt_type alts)
   = sep [sep [text "case",
            nest 4 (hsep [pprStgExpr expr,
-             ifPprDebug (dcolon <+> ppr alt_type)]),
+             whenPprDebug (dcolon <+> ppr alt_type)]),
            text "of", pprBndr CaseBind bndr, char '{'],
            nest 2 (vcat (map pprStgAlt alts)),
            char '}']
@@ -801,9 +819,11 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
 
 -- special case
 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
-  = hsep [ ppr cc,
+  = sdocWithDynFlags $ \dflags ->
+    hsep [ ppr cc,
            pp_binder_info bi,
-           brackets (ifPprDebug (ppr free_var)),
+           if not $ gopt Opt_SuppressStgFreeVars dflags
+             then brackets (ppr free_var) else empty,
            text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
 
 -- general case
@@ -811,7 +831,8 @@ pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
                 pp_binder_info bi,
-                ifPprDebug (brackets (interppSP free_vars)),
+                if not $ gopt Opt_SuppressStgFreeVars dflags
+                  then brackets (interppSP free_vars) else empty,
                 char '\\' <> ppr upd_flag, brackets (interppSP args)])
          4 (ppr body)
 
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 49912413e4..b606804079 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -13,6 +13,8 @@ module DmdAnal ( dmdAnalProgram ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import WwLib            ( findTypeShape, deepSplitProductType_maybe )
 import Demand   -- All of it
@@ -399,7 +401,7 @@ situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
 
 So if the scrutinee is a primop call, we *don't* apply the
 state hack:
-  - If is a simple, terminating one like getMaskingState,
+  - If it is a simple, terminating one like getMaskingState,
     applying the hack is over-conservative.
   - If the primop is raise# then it returns bottom, so
     the case alternatives are already discarded.
@@ -642,7 +644,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
            Nothing | (bndrs, body) <- collectBinders rhs
                    -> (bndrs, body, mkBodyDmd env body)
 
-    env_body         = foldl extendSigsWithLam env bndrs
+    env_body         = foldl' extendSigsWithLam env bndrs
     (body_ty, body') = dmdAnal env_body body_dmd body
     body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info
     (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
@@ -1191,7 +1193,7 @@ extendSigsWithLam env id
 extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
 -- See Note [CPR in a product case alternative]
 extendEnvForProdAlt env scrut case_bndr dc bndrs
-  = foldl do_con_arg env1 ids_w_strs
+  = foldl' do_con_arg env1 ids_w_strs
   where
     env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
 
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
index 9d741f5f4c..34cfd64ecd 100644
--- a/compiler/stranal/WorkWrap.hs
+++ b/compiler/stranal/WorkWrap.hs
@@ -7,6 +7,8 @@
 {-# LANGUAGE CPP #-}
 module WorkWrap ( wwTopBinds ) where
 
+import GhcPrelude
+
 import CoreSyn
 import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )
 import CoreUtils        ( exprType, exprIsHNF )
@@ -180,7 +182,7 @@ If we have
 
 where f is strict in y, we might get a more efficient loop by w/w'ing
 f.  But that would make a new unfolding which would overwrite the old
-one! So the function would no longer be ININABLE, and in particular
+one! So the function would no longer be INLNABLE, and in particular
 will not be specialised at call sites in other modules.
 
 This comes in practice (Trac #6056).
@@ -230,7 +232,7 @@ has no wrapper, the worker for g will rebox p. So we get
 
   g x y p = case p of (I# p#) -> $wg x y p#
 
-Now, in this case the reboxing will float into the True branch, an so
+Now, in this case the reboxing will float into the True branch, and so
 the allocation will only happen on the error path. But it won't float
 inwards if there are multiple branches that call (f p), so the reboxing
 will happen on every call of g. Disaster.
@@ -240,8 +242,8 @@ NOINLINE pragma to the worker.
 
 (See Trac #13143 for a real-world example.)
 
-Note [Activation for workers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Worker activation]
+~~~~~~~~~~~~~~~~~~~~~~~~
 Follows on from Note [Worker-wrapper for INLINABLE functions]
 
 It is *vital* that if the worker gets an INLINABLE pragma (from the
@@ -258,7 +260,9 @@ original activation. Consider
 
   f y = let z = expensive y in ...
 
-If expensive's worker inherits the wrapper's activation, we'll get
+If expensive's worker inherits the wrapper's activation,
+we'll get this (because of the compromise in point (2) of
+Note [Wrapper activation])
 
   {-# NOINLINE[0] $wexpensive #-}
   $wexpensive x = x + 1
@@ -344,36 +348,63 @@ call:
 
 Note [Wrapper activation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-When should the wrapper inlining be active?  It must not be active
-earlier than the current Activation of the Id (eg it might have a
-NOINLINE pragma).  But in fact strictness analysis happens fairly
-late in the pipeline, and we want to prioritise specialisations over
-strictness.  Eg if we have
-  module Foo where
-    f :: Num a => a -> Int -> a
-    f n 0 = n              -- Strict in the Int, hence wrapper
-    f n x = f (n+n) (x-1)
-
-    g :: Int -> Int
-    g x = f x x            -- Provokes a specialisation for f
-
-  module Bar where
-    import Foo
-
-    h :: Int -> Int
-    h x = f 3 x
-
-Then we want the specialisation for 'f' to kick in before the wrapper does.
-
-Now in fact the 'gentle' simplification pass encourages this, by
-having rules on, but inlinings off.  But that's kind of lucky. It seems
-more robust to give the wrapper an Activation of (ActiveAfter 0),
-so that it becomes active in an importing module at the same time that
-it appears in the first place in the defining module.
-
-At one stage I tried making the wrapper inlining always-active, and
-that had a very bad effect on nofib/imaginary/x2n1; a wrapper was
-inlined before the specialisation fired.
+When should the wrapper inlining be active?
+
+1. It must not be active earlier than the current Activation of the
+   Id
+
+2. It should be active at some point, despite (1) because of
+   Note [Worker-wrapper for NOINLINE functions]
+
+3. For ordinary functions with no pragmas we want to inline the
+   wrapper as early as possible (Trac #15056).  Suppose another module
+   defines    f x = g x x
+   and suppose there is some RULE for (g True True).  Then if we have
+   a call (f True), we'd expect to inline 'f' and the RULE will fire.
+   But if f is w/w'd (which it might be), we want the inlining to
+   occur just as if it hadn't been.
+
+   (This only matters if f's RHS is big enough to w/w, but small
+   enough to inline given the call site, but that can happen.)
+
+4. We do not want to inline the wrapper before specialisation.
+         module Foo where
+           f :: Num a => a -> Int -> a
+           f n 0 = n              -- Strict in the Int, hence wrapper
+           f n x = f (n+n) (x-1)
+
+           g :: Int -> Int
+           g x = f x x            -- Provokes a specialisation for f
+
+         module Bar where
+           import Foo
+
+           h :: Int -> Int
+           h x = f 3 x
+
+   In module Bar we want to give specialisations a chance to fire
+   before inlining f's wrapper.
+
+Reminder: Note [Don't w/w INLINE things], so we don't need to worry
+          about INLINE things here.
+
+Conclusion:
+  - If the user said NOINLINE[n], respect that
+  - If the user said NOINLINE, inline the wrapper as late as
+    poss (phase 0). This is a compromise driven by (2) above
+  - Otherwise inline wrapper in phase 2.  That allows the
+    'gentle' simplification pass to apply specialisation rules
+
+Historical note: At one stage I tried making the wrapper inlining
+always-active, and that had a very bad effect on nofib/imaginary/x2n1;
+a wrapper was inlined before the specialisation fired.
+
+Note [Wrapper NoUserInline]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The use an inl_inline of NoUserInline on the wrapper distinguishes
+this pragma from one that was given by the user. In particular, CSE
+will not happen if there is a user-specified pragma, but should happen
+for w/w’ed things (#14186).
 -}
 
 tryWW   :: DynFlags
@@ -463,29 +494,29 @@ splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult ->
 splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
   = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
     -- The arity should match the signature
-    stuff <- mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty
-                        wrap_dmds use_res_info
+    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info
     case stuff of
       Just (work_demands, join_arity, wrap_fn, work_fn) -> do
         work_uniq <- getUniqueM
         let work_rhs = work_fn rhs
-            work_inline = inl_inline inl_prag
-            work_act = case work_inline of
-              -- See Note [Activation for workers]
-              NoInline -> inl_act inl_prag
-              _        -> wrap_act
+            work_act = case fn_inline_spec of  -- See Note [Worker activation]
+                          NoInline -> fn_act
+                          _        -> wrap_act
+
             work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
-                                     , inl_inline = work_inline
+                                     , inl_inline = fn_inline_spec
                                      , inl_sat    = Nothing
                                      , inl_act    = work_act
                                      , inl_rule   = FunLike }
-              -- idl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]
-              -- idl_act: see Note [Activation for workers]
-              -- inl_rule: it does not make sense for workers to be constructorlike.
+              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]
+              -- inl_act:    see Note [Worker activation]
+              -- inl_rule:   it does not make sense for workers to be constructorlike.
+
             work_join_arity | isJoinId fn_id = Just join_arity
                             | otherwise      = Nothing
               -- worker is join point iff wrapper is join point
               -- (see Note [Don't CPR join points])
+
             work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)
                         `setIdOccInfo` occInfo fn_info
                                 -- Copy over occurrence info from parent
@@ -495,7 +526,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
 
                         `setInlinePragma` work_prag
 
-                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn (unfoldingInfo fn_info)
+                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding
                                 -- See Note [Worker-wrapper for INLINABLE functions]
 
                         `setIdStrictness` mkClosedStrictSig work_demands work_res_info
@@ -517,18 +548,21 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
             worker_demand | single_call = mkWorkerDemand work_arity
                           | otherwise   = topDmd
 
-
-            wrap_act  = ActiveAfter NoSourceText 0
             wrap_rhs  = wrap_fn work_id
-            wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
-                                     , inl_inline = Inline
+            wrap_act  = case fn_act of  -- See Note [Wrapper activation]
+                           ActiveAfter {} -> fn_act
+                           NeverActive    -> activeDuringFinal
+                           _              -> activeAfterInitial
+            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"
+                                     , inl_inline = NoUserInline
                                      , inl_sat    = Nothing
                                      , inl_act    = wrap_act
                                      , inl_rule   = rule_match_info }
-                -- See Note [Wrapper activation]
-                -- The RuleMatchInfo is (and must be) unaffected
+                -- inl_act:    see Note [Wrapper activation]
+                -- inl_inline: see Note [Wrapper NoUserInline]
+                -- inl_rule:   RuleMatchInfo is (and must be) unaffected
 
-            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule wrap_rhs arity
+            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity
                               `setInlinePragma` wrap_prag
                               `setIdOccInfo`    noOccInfo
                                 -- Zap any loop-breaker-ness, to avoid bleating from Lint
@@ -541,11 +575,12 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
 
       Nothing -> return [(fn_id, rhs)]
   where
-    mb_join_arity   = isJoinId_maybe fn_id
     rhs_fvs         = exprFreeVars rhs
-    fun_ty          = idType fn_id
-    inl_prag        = inlinePragInfo fn_info
-    rule_match_info = inlinePragmaRuleMatchInfo inl_prag
+    fn_inl_prag     = inlinePragInfo fn_info
+    fn_inline_spec  = inl_inline fn_inl_prag
+    fn_act          = inl_act fn_inl_prag
+    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag
+    fn_unfolding    = unfoldingInfo fn_info
     arity           = arityInfo fn_info
                     -- The arity is set by the simplifier using exprEtaExpandArity
                     -- So it may be more than the number of top-level-visible lambdas
@@ -654,7 +689,7 @@ then the splitting will go deeper too.
 splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
 splitThunk dflags fam_envs is_rec fn_id rhs
   = ASSERT(not (isJoinId fn_id))
-    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs [fn_id]
+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]
        ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
        ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
                    return res
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index f83aafe7b0..040a6d7da9 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -13,17 +13,20 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import CoreSyn
 import CoreUtils        ( exprType, mkCast )
 import Id
 import IdInfo           ( JoinArity, vanillaIdInfo )
 import DataCon
 import Demand
-import MkCore           ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup
+import MkCore           ( mkAbsentErrorApp, mkCoreUbxTup
                         , mkCoreApp, mkCoreLet )
 import MkId             ( voidArgId, voidPrimId )
-import TysPrim          ( voidPrimTy )
 import TysWiredIn       ( tupleDataCon )
+import TysPrim          ( voidPrimTy )
+import Literal          ( absentLiteralOf )
 import VarEnv           ( mkInScopeSet )
 import VarSet           ( VarSet )
 import Type
@@ -31,7 +34,6 @@ import RepType          ( isVoidTy )
 import Coercion
 import FamInstEnv
 import BasicTypes       ( Boxity(..) )
-import Literal          ( absentLiteralOf )
 import TyCon
 import UniqSupply
 import Unique
@@ -121,8 +123,7 @@ mkWwBodies :: DynFlags
            -> FamInstEnvs
            -> VarSet         -- Free vars of RHS
                              -- See Note [Freshen WW arguments]
-           -> Maybe JoinArity -- Just ar <=> is join point with join arity ar
-           -> Type           -- Type of original function
+           -> Id             -- The original function
            -> [Demand]       -- Strictness of original function
            -> DmdResult      -- Info about function result
            -> UniqSM (Maybe WwResult)
@@ -138,12 +139,14 @@ mkWwBodies :: DynFlags
 --                        let x = (a,b) in
 --                        E
 
-mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info
+mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info
   = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
                 -- See Note [Freshen WW arguments]
 
-        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands
-        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+             <- mkWWargs empty_subst fun_ty demands
+        ; (useful1, work_args, wrap_fn_str, work_fn_str)
+             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
         ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
@@ -156,7 +159,7 @@ mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info
 
         ; if isWorkerSmallEnough dflags work_args
              && not (too_many_args_for_join_point wrap_args)
-             && (useful1 && not only_one_void_argument || useful2)
+             && ((useful1 && not only_one_void_argument) || useful2)
           then return (Just (worker_args_dmds, length work_call_args,
                        wrapper_body, worker_body))
           else return Nothing
@@ -169,6 +172,11 @@ mkWwBodies dflags fam_envs rhs_fvs mb_join_arity fun_ty demands res_info
         -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
         -- fw from being inlined into f's RHS
   where
+    fun_ty        = idType fun_id
+    mb_join_arity = isJoinId_maybe fun_id
+    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)
+                          -- See Note [Do not unpack class dictionaries]
+
     -- Note [Do not split void functions]
     only_one_void_argument
       | [d] <- demands
@@ -261,11 +269,21 @@ mkWorkerArgs dflags args res_ty
     | otherwise
     = (args ++ [voidArgId], args ++ [voidPrimId])
     where
+      -- See "Making wrapper args" section above
       needsAValueLambda =
-        isUnliftedType res_ty
+        lifted
+        -- We may encounter a levity-polymorphic result, in which case we
+        -- conservatively assume that we have laziness that needs preservation.
+        -- See #15186.
         || not (gopt Opt_FunToThunk dflags)
            -- see Note [Protecting the last value argument]
 
+      -- Might the result be lifted?
+      lifted =
+        case isLiftedType_maybe res_ty of
+          Just lifted -> lifted
+          Nothing     -> True
+
 {-
 Note [Protecting the last value argument]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -488,6 +506,8 @@ To avoid this:
 
 mkWWstr :: DynFlags
         -> FamInstEnvs
+        -> Bool    -- True <=> INLINEABLE pragama on this function defn
+                   -- See Note [Do not unpack class dictionaries]
         -> [Var]                                -- Wrapper args; have their demand info on them
                                                 --  *Includes type variables*
         -> UniqSM (Bool,                        -- Is this useful
@@ -499,13 +519,18 @@ mkWWstr :: DynFlags
                    CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
                                                 -- and lacking its lambdas.
                                                 -- This fn does the reboxing
-mkWWstr _ _ []
-  = return (False, [], nop_fn, nop_fn)
+mkWWstr dflags fam_envs has_inlineable_prag args
+  = go args
+  where
+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
 
-mkWWstr dflags fam_envs (arg : args) = do
-    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg
-    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args
-    return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
+    go []           = return (False, [], nop_fn, nop_fn)
+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args
+                         ; return ( useful1 || useful2
+                                  , args1 ++ args2
+                                  , wrap_fn1 . wrap_fn2
+                                  , work_fn1 . work_fn2) }
 
 {-
 Note [Unpacking arguments with product and polymorphic demands]
@@ -542,9 +567,12 @@ as-yet-un-filled-in pkgState files.
 --        brings into scope work_args (via cases)
 --   * work_fn assumes work_args are in scope, a
 --        brings into scope wrap_arg (via lets)
-mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
-    -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-mkWWstr_one dflags fam_envs arg
+mkWWstr_one :: DynFlags -> FamInstEnvs
+            -> Bool    -- True <=> INLINEABLE pragama on this function defn
+                       -- See Note [Do not unpack class dictionaries]
+            -> Var
+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one dflags fam_envs has_inlineable_prag arg
   | isTyVar arg
   = return (False, [arg],  nop_fn, nop_fn)
 
@@ -579,8 +607,10 @@ mkWWstr_one dflags fam_envs arg
   | isStrictDmd dmd
   , Just cs <- splitProdDmd_maybe dmd
       -- See Note [Unpacking arguments with product and polymorphic demands]
+  , not (has_inlineable_prag && isClassPred arg_ty)
+      -- See Note [Do not unpack class dictionaries]
   , Just (data_con, inst_tys, inst_con_arg_tys, co)
-             <- deepSplitProductType_maybe fam_envs (idType arg)
+             <- deepSplitProductType_maybe fam_envs arg_ty
   , cs `equalLength` inst_con_arg_tys
       -- See Note [mkWWstr and unsafeCoerce]
   = do { (uniq1:uniqs) <- getUniquesM
@@ -592,7 +622,7 @@ mkWWstr_one dflags fam_envs arg
                              -- in Simplify.hs; and see Trac #13890
                 rebox_fn   = Let (NonRec arg_no_unf con_app)
                 con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args
          ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead
 
@@ -600,7 +630,8 @@ mkWWstr_one dflags fam_envs arg
   = return (False, [arg], nop_fn, nop_fn)
 
   where
-    dmd = idDemandInfo arg
+    arg_ty = idType arg
+    dmd    = idDemandInfo arg
     mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
 
 ----------------------
@@ -678,10 +709,12 @@ BUT if f is strict in the Ord dictionary, we might unpack it, to get
 and the type-class specialiser can't specialise that.  An example is
 Trac #6056.
 
-Moreover, dictionaries can have a lot of fields, so unpacking them can
-increase closure sizes.
+But in any other situation a dictionary is just an ordinary value,
+and can be unpacked.  So we track the INLINABLE pragma, and switch
+off the unpacking in mkWWstr_one (see the isClassPred test).
 
-Conclusion: don't unpack dictionaries.
+Historical note: Trac #14955 describes how I got this fix wrong
+the first time.
 -}
 
 deepSplitProductType_maybe
@@ -697,7 +730,6 @@ deepSplitProductType_maybe fam_envs ty
                     `orElse` (mkRepReflCo ty, ty)
   , Just (tc, tc_args) <- splitTyConApp_maybe ty1
   , Just con <- isDataProductTyCon_maybe tc
-  , not (isClassTyCon tc)  -- See Note [Do not unpack class dictionaries]
   , let arg_tys = dataConInstArgTys con tc_args
         strict_marks = dataConRepStrictness con
   = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
@@ -893,15 +925,24 @@ example, Trac #4306.  For these we find a suitable literal,
 using Literal.absentLiteralOf.  We don't have literals for
 every primitive type, so the function is partial.
 
-    [I did try the experiment of using an error thunk for unlifted
-    things too, relying on the simplifier to drop it as dead code,
-    by making absentError
-      (a) *not* be a bottoming Id,
-      (b) be "ok for speculation"
-    But that relies on the simplifier finding that it really
-    is dead code, which is fragile, and indeed failed when
-    profiling is on, which disables various optimisations.  So
-    using a literal will do.]
+Note: I did try the experiment of using an error thunk for unlifted
+things too, relying on the simplifier to drop it as dead code.
+But this is fragile
+
+ - It fails when profiling is on, which disables various optimisations
+
+ - It fails when reboxing happens. E.g.
+      data T = MkT Int Int#
+      f p@(MkT a _) = ...g p....
+   where g is /lazy/ in 'p', but only uses the first component.  Then
+   'f' is /strict/ in 'p', and only uses the first component.  So we only
+   pass that component to the worker for 'f', which reconstructs 'p' to
+   pass it to 'g'.  Alas we can't say
+       ...f (MkT a (absentError Int# "blah"))...
+   bacause `MkT` is strict in its Int# argument, so we get an absentError
+   exception when we shouldn't.  Very annoying!
+
+So absentError is only used for lifted types.
 -}
 
 mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
@@ -917,12 +958,12 @@ mk_absent_let dflags arg
   = WARN( True, text "No absent value for" <+> ppr arg_ty )
     Nothing
   where
-    arg_ty     = idType arg
-    abs_rhs    = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
     lifted_arg = arg `setIdStrictness` exnSig
               -- Note in strictness signature that this is bottoming
               -- (for the sake of the "empty case scrutinee not known to
               -- diverge for sure lint" warning)
+    arg_ty     = idType arg
+    abs_rhs    = mkAbsentErrorApp arg_ty msg
     msg        = showSDoc (gopt_set dflags Opt_SuppressUniques)
                           (ppr arg <+> ppr (idType arg))
               -- We need to suppress uniques here because otherwise they'd
diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs
new file mode 100644
index 0000000000..0af1965ec8
--- /dev/null
+++ b/compiler/typecheck/ClsInst.hs
@@ -0,0 +1,595 @@
+{-# LANGUAGE CPP #-}
+
+module ClsInst (
+     matchGlobalInst,
+     ClsInstResult(..),
+     InstanceWhat(..), safeOverlap
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcEnv
+import TcRnMonad
+import TcType
+import TcMType
+import TcEvidence
+import RnEnv( addUsedGRE )
+import RdrName( lookupGRE_FieldLabel )
+import InstEnv
+import Inst( instDFunType )
+import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
+
+import TysWiredIn
+import TysPrim( eqPrimTyCon, eqReprPrimTyCon )
+import PrelNames
+
+import Id
+import Type
+import MkCore ( mkStringExprFS, mkNaturalExpr )
+
+import Unique ( hasKey )
+import Name   ( Name )
+import Var    ( DFunId )
+import DataCon
+import TyCon
+import Class
+import DynFlags
+import Outputable
+import Util( splitAtList, fstOf3 )
+import Data.Maybe
+
+{- *******************************************************************
+*                                                                    *
+                       Class lookup
+*                                                                    *
+**********************************************************************-}
+
+-- | Indicates if Instance met the Safe Haskell overlapping instances safety
+-- check.
+--
+-- See Note [Safe Haskell Overlapping Instances] in TcSimplify
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+type SafeOverlapping = Bool
+
+data ClsInstResult
+  = NoInstance   -- Definitely no instance
+
+  | OneInst { cir_new_theta :: [TcPredType]
+            , cir_mk_ev     :: [EvExpr] -> EvTerm
+            , cir_what      :: InstanceWhat }
+
+  | NotSure      -- Multiple matches and/or one or more unifiers
+
+data InstanceWhat
+  = BuiltinInstance
+  | LocalInstance
+  | TopLevInstance { iw_dfun_id   :: DFunId
+                   , iw_safe_over :: SafeOverlapping }
+
+instance Outputable ClsInstResult where
+  ppr NoInstance = text "NoInstance"
+  ppr NotSure    = text "NotSure"
+  ppr (OneInst { cir_new_theta = ev
+               , cir_what = what })
+    = text "OneInst" <+> vcat [ppr ev, ppr what]
+
+instance Outputable InstanceWhat where
+  ppr BuiltinInstance = text "built-in instance"
+  ppr LocalInstance   = text "locally-quantified instance"
+  ppr (TopLevInstance { iw_safe_over = so })
+     = text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")
+
+safeOverlap :: InstanceWhat -> Bool
+safeOverlap (TopLevInstance { iw_safe_over = so }) = so
+safeOverlap _                                      = True
+
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcM ClsInstResult
+matchGlobalInst dflags short_cut clas tys
+  | cls_name == knownNatClassName     = matchKnownNat        clas tys
+  | cls_name == knownSymbolClassName  = matchKnownSymbol     clas tys
+  | isCTupleClass clas                = matchCTuple          clas tys
+  | cls_name == typeableClassName     = matchTypeable        clas tys
+  | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys
+  | clas `hasKey` eqTyConKey          = matchHomoEquality         tys
+  | clas `hasKey` coercibleTyConKey   = matchCoercible            tys
+  | cls_name == hasFieldClassName     = matchHasField dflags short_cut clas tys
+  | otherwise                         = matchInstEnv dflags short_cut clas tys
+  where
+    cls_name = className clas
+
+
+{- ********************************************************************
+*                                                                     *
+                   Looking in the instance environment
+*                                                                     *
+***********************************************************************-}
+
+
+matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchInstEnv dflags short_cut_solver clas tys
+   = do { instEnvs <- tcGetInstEnvs
+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
+        ; traceTc "matchInstEnv" $
+            vcat [ text "goal:" <+> ppr clas <+> ppr tys
+                 , text "matches:" <+> ppr matches
+                 , text "unify:" <+> ppr unify ]
+        ; case (matches, unify, safeHaskFail) of
+
+            -- Nothing matches
+            ([], [], _)
+                -> do { traceTc "matchClass not matching" (ppr pred)
+                      ; return NoInstance }
+
+            -- A single match (& no safe haskell failure)
+            ([(ispec, inst_tys)], [], False)
+                | short_cut_solver      -- Called from the short-cut solver
+                , isOverlappable ispec
+                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
+                -- then don't let the short-cut solver choose it, because a
+                -- later instance might overlap it.  Trac #14434 is an example
+                -- See Note [Shortcut solving: overlap]
+                -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)
+                      ; return NotSure }
+
+                | otherwise
+                -> do { let dfun_id = instanceDFunId ispec
+                      ; traceTc "matchClass success" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "witness" <+> ppr dfun_id
+                                             <+> ppr (idType dfun_id) ]
+                                -- Record that this dfun is needed
+                      ; match_one (null unsafeOverlaps) dfun_id inst_tys }
+
+            -- More than one matches (or Safe Haskell fail!). Defer any
+            -- reactions of a multitude until we learn more about the reagent
+            _   -> do { traceTc "matchClass multiple matches, deferring choice" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "matches" <+> ppr matches]
+                      ; return NotSure } }
+   where
+     pred = mkClassPred clas tys
+
+match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
+             -- See Note [DFunInstType: instantiating types] in InstEnv
+match_one so dfun_id mb_inst_tys
+  = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)
+       ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+       ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
+       ; return $ OneInst { cir_new_theta = theta
+                          , cir_mk_ev     = evDFunApp dfun_id tys
+                          , cir_what      = TopLevInstance { iw_dfun_id = dfun_id
+                                                           , iw_safe_over = so } } }
+
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for CTuples
+*                                                                     *
+***********************************************************************-}
+
+matchCTuple :: Class -> [Type] -> TcM ClsInstResult
+matchCTuple clas tys   -- (isCTupleClass clas) holds
+  = return (OneInst { cir_new_theta = tys
+                    , cir_mk_ev     = tuple_ev
+                    , cir_what      = BuiltinInstance })
+            -- The dfun *is* the data constructor!
+  where
+     data_con = tyConSingleDataCon (classTyCon clas)
+     tuple_ev = evDFunApp (dataConWrapId data_con) tys
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Literals
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [KnownNat & KnownSymbol and EvLit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A part of the type-level literals implementation are the classes
+"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
+defining singleton values.  Here is the key stuff from GHC.TypeLits
+
+  class KnownNat (n :: Nat) where
+    natSing :: SNat n
+
+  newtype SNat (n :: Nat) = SNat Integer
+
+Conceptually, this class has infinitely many instances:
+
+  instance KnownNat 0       where natSing = SNat 0
+  instance KnownNat 1       where natSing = SNat 1
+  instance KnownNat 2       where natSing = SNat 2
+  ...
+
+In practice, we solve `KnownNat` predicates in the type-checker
+(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
+The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
+
+We make the following assumptions about dictionaries in GHC:
+  1. The "dictionary" for classes with a single method---like `KnownNat`---is
+     a newtype for the type of the method, so using a evidence amounts
+     to a coercion, and
+  2. Newtypes use the same representation as their definition types.
+
+So, the evidence for `KnownNat` is just a value of the representation type,
+wrapped in two newtype constructors: one to make it into a `SNat` value,
+and another to make it into a `KnownNat` dictionary.
+
+Also note that `natSing` and `SNat` are never actually exposed from the
+library---they are just an implementation detail.  Instead, users see
+a more convenient function, defined in terms of `natSing`:
+
+  natVal :: KnownNat n => proxy n -> Integer
+
+The reason we don't use this directly in the class is that it is simpler
+and more efficient to pass around an integer rather than an entire function,
+especially when the `KnowNat` evidence is packaged up in an existential.
+
+The story for kind `Symbol` is analogous:
+  * class KnownSymbol
+  * newtype SSymbol
+  * Evidence: a Core literal (e.g. mkNaturalExpr)
+-}
+
+matchKnownNat :: Class -> [Type] -> TcM ClsInstResult
+matchKnownNat clas [ty]     -- clas = KnownNat
+  | Just n <- isNumLitTy ty = do
+        et <- mkNaturalExpr n
+        makeLitDict clas ty et
+matchKnownNat _ _           = return NoInstance
+
+matchKnownSymbol :: Class -> [Type] -> TcM ClsInstResult
+matchKnownSymbol clas [ty]  -- clas = KnownSymbol
+  | Just s <- isStrLitTy ty = do
+        et <- mkStringExprFS s
+        makeLitDict clas ty et
+matchKnownSymbol _ _       = return NoInstance
+
+makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
+-- makeLitDict adds a coercion that will convert the literal into a dictionary
+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
+-- in TcEvidence.  The coercion happens in 2 steps:
+--
+--     Integer -> SNat n     -- representation of literal to singleton
+--     SNat n  -> KnownNat n -- singleton to dictionary
+--
+--     The process is mirrored for Symbols:
+--     String    -> SSymbol n
+--     SSymbol n -> KnownSymbol n
+makeLitDict clas ty et
+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+          -- co_dict :: KnownNat n ~ SNat n
+    , [ meth ]   <- classMethods clas
+    , Just tcRep <- tyConAppTyCon_maybe -- SNat
+                      $ funResultTy         -- SNat n
+                      $ dropForAlls         -- KnownNat n => SNat n
+                      $ idType meth         -- forall n. KnownNat n => SNat n
+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
+          -- SNat n ~ Integer
+    , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
+    = return $ OneInst { cir_new_theta = []
+                       , cir_mk_ev     = \_ -> ev_tm
+                       , cir_what      = BuiltinInstance }
+
+    | otherwise
+    = pprPanic "makeLitDict" $
+      text "Unexpected evidence for" <+> ppr (className clas)
+      $$ vcat (map (ppr . idType) (classMethods clas))
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Typeable
+*                                                                     *
+***********************************************************************-}
+
+-- | Assumes that we've checked that this is the 'Typeable' class,
+-- and it was applied to the correct argument.
+matchTypeable :: Class -> [Type] -> TcM ClsInstResult
+matchTypeable clas [k,t]  -- clas = Typeable
+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
+  | isForAllTy k                      = return NoInstance   -- Polytype
+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type
+
+  -- Now cases that do work
+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t
+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t
+  | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []
+  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret
+  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
+  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
+
+matchTypeable _ _ = return NoInstance
+
+-- | Representation for a type @ty@ of the form @arg -> ret@.
+doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult
+doFunTy clas ty arg_ty ret_ty
+  = return $ OneInst { cir_new_theta = preds
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]
+    mk_ev [arg_ev, ret_ev] = evTypeable ty $
+                             EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev)
+    mk_ev _ = panic "TcInteract.doFunTy"
+
+
+-- | Representation for type constructor applied to some kinds.
+-- 'onlyNamedBndrsApplied' has ensured that this application results in a type
+-- of monomorphic kind (e.g. all kind variables have been instantiated).
+doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
+doTyConApp clas ty tc kind_args
+  | Just _ <- tyConRepName_maybe tc
+  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  | otherwise
+  = return NoInstance
+  where
+    mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds)
+
+-- | Representation for TyCon applications of a concrete kind. We just use the
+-- kind itself, but first we must make sure that we've instantiated all kind-
+-- polymorphism, but no more.
+onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
+onlyNamedBndrsApplied tc ks
+ = all isNamedTyConBinder used_bndrs &&
+   not (any isNamedTyConBinder leftover_bndrs)
+ where
+   bndrs                        = tyConBinders tc
+   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs
+
+doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
+-- Representation for an application of a type to a type-or-kind.
+--  This may happen when the type expression starts with a type variable.
+--  Example (ignoring kind parameter):
+--    Typeable (f Int Char)                      -->
+--    (Typeable (f Int), Typeable Char)          -->
+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
+--    Typeable f
+doTyApp clas ty f tk
+  | isForAllTy (typeKind f)
+  = return NoInstance -- We can't solve until we know the ctr.
+  | otherwise
+  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk]
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)
+    mk_ev _ = panic "doTyApp"
+
+
+-- Emit a `Typeable` constraint for the given type.
+mk_typeable_pred :: Class -> Type -> PredType
+mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
+
+  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
+  -- we generate a sub-goal for the appropriate class.
+  -- See Note [Typeable for Nat and Symbol]
+doTyLit :: Name -> Type -> TcM ClsInstResult
+doTyLit kc t = do { kc_clas <- tcLookupClass kc
+                  ; let kc_pred    = mkClassPred kc_clas [ t ]
+                        mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)
+                        mk_ev _    = panic "doTyLit"
+                  ; return (OneInst { cir_new_theta = [kc_pred]
+                                    , cir_mk_ev     = mk_ev
+                                    , cir_what      = BuiltinInstance }) }
+
+{- Note [Typeable (T a b c)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For type applications we always decompose using binary application,
+via doTyApp, until we get to a *kind* instantiation.  Example
+   Proxy :: forall k. k -> *
+
+To solve Typeable (Proxy (* -> *) Maybe) we
+  - First decompose with doTyApp,
+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
+  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp
+
+If we attempt to short-cut by solving it all at once, via
+doTyConApp
+
+(this note is sadly truncated FIXME)
+
+
+Note [No Typeable for polytypes or qualified types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not support impredicative typeable, such as
+   Typeable (forall a. a->a)
+   Typeable (Eq a => a -> a)
+   Typeable (() => Int)
+   Typeable (((),()) => Int)
+
+See Trac #9858.  For forall's the case is clear: we simply don't have
+a TypeRep for them.  For qualified but not polymorphic types, like
+(Eq a => a -> a), things are murkier.  But:
+
+ * We don't need a TypeRep for these things.  TypeReps are for
+   monotypes only.
+
+ * Perhaps we could treat `=>` as another type constructor for `Typeable`
+   purposes, and thus support things like `Eq Int => Int`, however,
+   at the current state of affairs this would be an odd exception as
+   no other class works with impredicative types.
+   For now we leave it off, until we have a better story for impredicativity.
+
+
+Note [Typeable for Nat and Symbol]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have special Typeable instances for Nat and Symbol.  Roughly we
+have this instance, implemented here by doTyLit:
+      instance KnownNat n => Typeable (n :: Nat) where
+         typeRep = typeNatTypeRep @n
+where
+   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a
+
+Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a
+runtime value 'n'; it turns it into a string with 'show' and uses
+that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.
+See #10348.
+
+Because of this rule it's inadvisable (see #15322) to have a constraint
+    f :: (Typeable (n :: Nat)) => blah
+in a function signature; it gives rise to overlap problems just as
+if you'd written
+    f :: Eq [a] => blah
+-}
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for lifted equality
+*                                                                     *
+***********************************************************************-}
+
+-- See also Note [The equality types story] in TysPrim
+matchHeteroEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~~ t2)
+matchHeteroEquality args
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
+                    , cir_mk_ev     = evDFunApp (dataConWrapId heqDataCon) args
+                    , cir_what      = BuiltinInstance })
+
+matchHomoEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~ t2)
+matchHomoEquality args@[k,t1,t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
+                    , cir_mk_ev     = evDFunApp (dataConWrapId eqDataCon) args
+                    , cir_what      = BuiltinInstance })
+matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
+
+-- See also Note [The equality types story] in TysPrim
+matchCoercible :: [Type] -> TcM ClsInstResult
+matchCoercible args@[k, t1, t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
+                    , cir_mk_ev     = evDFunApp (dataConWrapId coercibleDataCon)
+                                                args
+                    , cir_what      = BuiltinInstance })
+  where
+    args' = [k, k, t1, t2]
+matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
+
+
+{- ********************************************************************
+*                                                                     *
+              Class lookup for overloaded record fields
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+    data T y = MkT { foo :: [y] }
+
+and `foo` is in scope.  Then GHC will automatically solve a constraint like
+
+    HasField "foo" (T Int) b
+
+by emitting a new wanted
+
+    T alpha -> [alpha] ~# T Int -> b
+
+and building a HasField dictionary out of the selector function `foo`,
+appropriately cast.
+
+The HasField class is defined (in GHC.Records) thus:
+
+    class HasField (x :: k) r a | x r -> a where
+      getField :: r -> a
+
+Since this is a one-method class, it is represented as a newtype.
+Hence we can solve `HasField "foo" (T Int) b` by taking an expression
+of type `T Int -> b` and casting it using the newtype coercion.
+Note that
+
+    foo :: forall y . T y -> [y]
+
+so the expression we construct is
+
+    foo @alpha |> co
+
+where
+
+    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
+
+is built from
+
+    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
+
+which is the new wanted, and
+
+    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
+
+which can be derived from the newtype coercion.
+
+If `foo` is not in scope, or has a higher-rank or existentially
+quantified type, then the constraint is not solved automatically, but
+may be solved by a user-supplied HasField instance.  Similarly, if we
+encounter a HasField constraint where the field is not a literal
+string, or does not belong to the type, then we fall back on the
+normal constraint solver behaviour.
+-}
+
+-- See Note [HasField instances]
+matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchHasField dflags short_cut clas tys
+  = do { fam_inst_envs <- tcGetFamInstEnvs
+       ; rdr_env       <- getGlobalRdrEnv
+       ; case tys of
+           -- We are matching HasField {k} x r a...
+           [_k_ty, x_ty, r_ty, a_ty]
+               -- x should be a literal string
+             | Just x <- isStrLitTy x_ty
+               -- r should be an applied type constructor
+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
+               -- use representation tycon (if data family); it has the fields
+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
+               -- x should be a field of r
+             , Just fl <- lookupTyConFieldLabel x r_tc
+               -- the field selector should be in scope
+             , Just gre <- lookupGRE_FieldLabel rdr_env fl
+
+             -> do { sel_id <- tcLookupId (flSelector fl)
+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
+
+                         -- The first new wanted constraint equates the actual
+                         -- type of the selector with the type (r -> a) within
+                         -- the HasField x r a dictionary.  The preds will
+                         -- typically be empty, but if the datatype has a
+                         -- "stupid theta" then we have to include it here.
+                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
+
+                         -- Use the equality proof to cast the selector Id to
+                         -- type (r -> a), then use the newtype coercion to cast
+                         -- it to a HasField dictionary.
+                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co
+                           where
+                             co = mkTcSubCo (evTermCoercion (EvExpr ev1))
+                                      `mkTcTransCo` mkTcSymCo co2
+                         mk_ev [] = panic "matchHasField.mk_ev"
+
+                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
+                                                              tys
+
+                         tvs = mkTyVarTys (map snd tv_prs)
+
+                     -- The selector must not be "naughty" (i.e. the field
+                     -- cannot have an existentially quantified type), and
+                     -- it must not be higher-rank.
+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
+                     then do { addUsedGRE True gre
+                             ; return OneInst { cir_new_theta = theta
+                                              , cir_mk_ev     = mk_ev
+                                              , cir_what      = BuiltinInstance } }
+                     else matchInstEnv dflags short_cut clas tys }
+
+           _ -> matchInstEnv dflags short_cut clas tys }
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 87a602c783..00602ecba5 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -7,17 +7,19 @@ module FamInst (
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
         tcLookupDataFamInst, tcLookupDataFamInst_maybe,
         tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
-        checkRecFamInstConsistency,
         newFamInst,
 
         -- * Injectivity
         makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes
     ) where
 
+import GhcPrelude
+
 import HscTypes
 import FamInstEnv
 import InstEnv( roughMatchTcs )
 import Coercion
+import CoreLint
 import TcEvidence
 import LoadIface
 import TcRnMonad
@@ -41,15 +43,11 @@ import Panic
 import VarSet
 import Bag( Bag, unionBags, unitBag )
 import Control.Monad
-import NameEnv
-import Data.List
 
 #include "HsVersions.h"
 
-{-
-
-Note [The type family instance consistency story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [The type family instance consistency story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 To preserve type safety we must ensure that for any given module, all
 the type family instances used either in that module or in any module
@@ -100,8 +98,7 @@ defined in the module M itself. This is a pairwise check, i.e., for
 every pair of instances we must check that they are consistent.
 
 - For family instances coming from `dep_finsts`, this is checked in
-checkFamInstConsistency, called from tcRnImports, and in
-checkRecFamInstConsistency, called from tcTyClGroup. See Note
+checkFamInstConsistency, called from tcRnImports. See Note
 [Checking family instance consistency] for details on this check (and
 in particular how we avoid having to do all these checks for every
 module we compile).
@@ -155,20 +152,30 @@ See #9562.
 
 newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
 -- Freshen the type variables of the FamInst branches
--- Called from the vectoriser monad too, hence the rather general type
 newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
   = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )
     ASSERT2( tyCoVarsOfType  rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax )
     ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )
     do { (subst, tvs') <- freshenTyVarBndrs tvs
        ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
+       ; dflags <- getDynFlags
+       ; let lhs'     = substTys subst lhs
+             rhs'     = substTy  subst rhs
+             tcvs'    = tvs' ++ cvs'
+       ; when (gopt Opt_DoCoreLinting dflags) $
+           -- Check that the types involved in this instance are well formed.
+           -- Do /not/ expand type synonyms, for the reasons discussed in
+           -- Note [Linting type synonym applications].
+           case lintTypes dflags tcvs' (rhs':lhs') of
+             Nothing       -> pure ()
+             Just fail_msg -> pprPanic "Core Lint error" fail_msg
        ; return (FamInst { fi_fam      = tyConName fam_tc
                          , fi_flavor   = flavor
                          , fi_tcs      = roughMatchTcs lhs
                          , fi_tvs      = tvs'
                          , fi_cvs      = cvs'
-                         , fi_tys      = substTys subst lhs
-                         , fi_rhs      = substTy  subst rhs
+                         , fi_tys      = lhs'
+                         , fi_rhs      = rhs'
                          , fi_axiom    = axiom }) }
   where
     lhs_kind = typeKind (mkTyConApp fam_tc lhs)
@@ -274,16 +281,14 @@ This is basically the idea from #13092, comment:14.
 -- This function doesn't check ALL instances for consistency,
 -- only ones that aren't involved in recursive knot-tying
 -- loops; see Note [Don't check hs-boot type family instances too early].
--- It returns a modified 'TcGblEnv' that has saved the
--- instances that need to be checked later; use 'checkRecFamInstConsistency'
--- to check those.
 -- We don't need to check the current module, this is done in
 -- tcExtendLocalFamInstEnv.
 -- See Note [The type family instance consistency story].
-checkFamInstConsistency :: [Module] -> TcM TcGblEnv
+checkFamInstConsistency :: [Module] -> TcM ()
 checkFamInstConsistency directlyImpMods
   = do { dflags     <- getDynFlags
        ; (eps, hpt) <- getEpsAndHpt
+       ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
        ; let { -- Fetch the iface of a given module.  Must succeed as
                -- all directly imported modules must already have been loaded.
                modIface mod =
@@ -311,10 +316,7 @@ checkFamInstConsistency directlyImpMods
 
              }
 
-       ; pending_checks <- checkMany hpt_fam_insts modConsistent directlyImpMods
-       ; tcg_env <- getGblEnv
-       ; return tcg_env { tcg_pending_fam_checks
-                           = foldl' (plusNameEnv_C (++)) emptyNameEnv pending_checks }
+       ; checkMany hpt_fam_insts modConsistent directlyImpMods
        }
   where
     -- See Note [Checking family instance optimization]
@@ -322,26 +324,24 @@ checkFamInstConsistency directlyImpMods
       :: ModuleEnv FamInstEnv   -- home package family instances
       -> (Module -> [Module])   -- given A, modules checked when A was checked
       -> [Module]               -- modules to process
-      -> TcM [NameEnv [([FamInst], FamInstEnv)]]
-    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods []
+      -> TcM ()
+    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods
       where
       go :: [Module] -- list of consistent modules
          -> ModuleSet -- set of consistent modules, same elements as the
                       -- list above
          -> [Module] -- modules to process
-         -> [NameEnv [([FamInst], FamInstEnv)]]
-           -- accumulator for pending checks
-         -> TcM [NameEnv [([FamInst], FamInstEnv)]]
-      go _ _ [] pending = return pending
-      go consistent consistent_set (mod:mods) pending = do
-        pending' <- sequence
+         -> TcM ()
+      go _ _ [] = return ()
+      go consistent consistent_set (mod:mods) = do
+        sequence_
           [ check hpt_fam_insts m1 m2
           | m1 <- to_check_from_mod
             -- loop over toCheckFromMod first, it's usually smaller,
             -- it may even be empty
           , m2 <- to_check_from_consistent
           ]
-        go consistent' consistent_set' mods (pending' ++ pending)
+        go consistent' consistent_set' mods
         where
         mod_deps_consistent =  modConsistent mod
         mod_deps_consistent_set = mkModuleSet mod_deps_consistent
@@ -356,10 +356,7 @@ checkFamInstConsistency directlyImpMods
         -- We could, but doing so means one of two things:
         --
         --   1. When looping over the cartesian product we convert
-        --   a set into a non-deterministicly ordered list - then
-        --   tcg_pending_fam_checks will end up storing some
-        --   non-deterministically ordered lists as well and
-        --   we end up with non-local non-determinism. Which
+        --   a set into a non-deterministicly ordered list. Which
         --   happens to be fine for interface file determinism
         --   in this case, today, because the order only
         --   determines the order of deferred checks. But such
@@ -406,7 +403,7 @@ checkFamInstConsistency directlyImpMods
            --   type family F a
            --
            -- When typechecking A, we are NOT allowed to poke the TyThing
-           -- for for F until we have typechecked the family.  Thus, we
+           -- for F until we have typechecked the family.  Thus, we
            -- can't do consistency checking for the instance in B
            -- (checkFamInstConsistency is called during renaming).
            -- Failing to defer the consistency check lead to #11062.
@@ -432,12 +429,9 @@ checkFamInstConsistency directlyImpMods
            --   import B
            --   data T = MkT
            --
-           -- However, this is not yet done; see #13981.
-           --
-           -- Note that it is NOT necessary to defer for occurrences in the
-           -- RHS (e.g., type instance F Int = T, in the above example),
-           -- since that never participates in consistency checking
-           -- in any nontrivial way.
+           -- In fact, it is even necessary to defer for occurrences in
+           -- the RHS, because we may test for *compatibility* in event
+           -- of an overlap.
            --
            -- Why don't we defer ALL of the checks to later?  Well, many
            -- instances aren't involved in the recursive loop at all.  So
@@ -449,42 +443,13 @@ checkFamInstConsistency directlyImpMods
            -- as quickly as possible, so that we aren't typechecking
            -- values with inconsistent axioms in scope.
            --
-           -- See also Note [Tying the knot] and Note [Type-checking inside the knot]
+           -- See also Note [Tying the knot]
            -- for why we are doing this at all.
-           ; this_mod <- getModule
-                    -- NB: == this_mod only holds if there's an hs-boot file;
-                    -- otherwise we cannot possible see instances for families
-                    -- defined by the module we are compiling in imports.
-           ; let shouldCheckNow = ((/= this_mod) . nameModule . fi_fam)
-                 (check_now, check_later) =
-                    partition shouldCheckNow (famInstEnvElts env1)
+           ; let check_now = famInstEnvElts env1
            ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
            ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
-           ; let check_later_map =
-                    extendNameEnvList_C (++) emptyNameEnv
-                        [(fi_fam finst, [finst]) | finst <- check_later]
-           ; return (mapNameEnv (\xs -> [(xs, env2)]) check_later_map)
  }
 
--- | Given a 'TyCon' that has been incorporated into the type
--- environment (the knot is tied), if it is a type family, check
--- that all deferred instances for it are consistent.
--- See Note [Don't check hs-boot type family instances too early]
-checkRecFamInstConsistency :: TyCon -> TcM ()
-checkRecFamInstConsistency tc = do
-   tcg_env <- getGblEnv
-   let checkConsistency tc
-        | isFamilyTyCon tc
-        , Just pairs <- lookupNameEnv (tcg_pending_fam_checks tcg_env)
-                                      (tyConName tc)
-        = forM_ pairs $ \(check_now, env2) -> do
-            mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
-            mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
-        | otherwise
-        = return ()
-   checkConsistency tc
-
-
 getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
 getFamInsts hpt_fam_insts mod
   | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
@@ -620,38 +585,57 @@ tcExtendLocalFamInstEnv [] thing_inside = thing_inside
 
 -- Otherwise proceed...
 tcExtendLocalFamInstEnv fam_insts thing_inside
- = do { env <- getGblEnv
-      ; let this_mod = tcg_mod env
-            imports = tcg_imports env
-
-            -- Optimization: If we're only defining type family instances
-            -- for type families *defined in the home package*, then we
-            -- only have to load interface files that belong to the home
-            -- package. The reason is that there's no recursion between
-            -- packages, so modules in other packages can't possibly define
-            -- instances for our type families.
-            --
-            -- (Within the home package, we could import a module M that
-            -- imports us via an hs-boot file, and thereby defines an
-            -- instance of a type family defined in this module. So we can't
-            -- apply the same logic to avoid reading any interface files at
-            -- all, when we define an instances for type family defined in
-            -- the current module.)
-            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts
-            want_module mod
-              | mod == this_mod = False
-              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod
-              | otherwise       = True
-      ; loadModuleInterfaces (text "Loading family-instance modules")
-                             (filter want_module (imp_finsts imports))
+ = do { -- Load family-instance modules "below" this module, so that
+        -- allLocalFamInst can check for consistency with them
+        -- See Note [The type family instance consistency story]
+        loadDependentFamInstModules fam_insts
+
+        -- Now add the instances one by one
+      ; env <- getGblEnv
       ; (inst_env', fam_insts') <- foldlM addLocalFamInst
                                        (tcg_fam_inst_env env, tcg_fam_insts env)
                                        fam_insts
+
       ; let env' = env { tcg_fam_insts    = fam_insts'
                        , tcg_fam_inst_env = inst_env' }
       ; setGblEnv env' thing_inside
       }
 
+loadDependentFamInstModules :: [FamInst] -> TcM ()
+-- Load family-instance modules "below" this module, so that
+-- allLocalFamInst can check for consistency with them
+-- See Note [The type family instance consistency story]
+loadDependentFamInstModules fam_insts
+ = do { env <- getGblEnv
+      ; let this_mod = tcg_mod env
+            imports  = tcg_imports env
+
+            want_module mod  -- See Note [Home package family instances]
+              | mod == this_mod = False
+              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod
+              | otherwise       = True
+            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts
+
+      ; loadModuleInterfaces (text "Loading family-instance modules") $
+        filter want_module (imp_finsts imports) }
+
+{- Note [Home package family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Optimization: If we're only defining type family instances
+for type families *defined in the home package*, then we
+only have to load interface files that belong to the home
+package. The reason is that there's no recursion between
+packages, so modules in other packages can't possibly define
+instances for our type families.
+
+(Within the home package, we could import a module M that
+imports us via an hs-boot file, and thereby defines an
+instance of a type family defined in this module. So we can't
+apply the same logic to avoid reading any interface files at
+all, when we define an instances for type family defined in
+the current module.
+-}
+
 -- Check that the proposed new instance is OK,
 -- and then add it to the home inst env
 -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
@@ -720,7 +704,7 @@ checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool
 checkForInjectivityConflicts instEnvs famInst
     | isTypeFamilyTyCon tycon
     -- type family is injective in at least one argument
-    , Injective inj <- familyTyConInjectivityInfo tycon = do
+    , Injective inj <- tyConInjectivityInfo tycon = do
     { let axiom = coAxiomSingleBranch fi_ax
           conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
           -- see Note [Verifying injectivity annotation] in FamInstEnv
@@ -808,7 +792,7 @@ injTyVarsOfType (TyVarTy v)
   = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)
 injTyVarsOfType (TyConApp tc tys)
   | isTypeFamilyTyCon tc
-   = case familyTyConInjectivityInfo tc of
+   = case tyConInjectivityInfo tc of
         NotInjective  -> emptyVarSet
         Injective inj -> injTyVarsOfTypes (filterByList inj tys)
   | otherwise
diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs
index 789254d230..768c78d28f 100644
--- a/compiler/typecheck/FunDeps.hs
+++ b/compiler/typecheck/FunDeps.hs
@@ -19,6 +19,8 @@ module FunDeps (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Name
 import Var
 import Class
@@ -237,7 +239,7 @@ improveClsFD clas_tvs fd
 --         for fundep (x,y -> p,q)  from class  (C x p y q)
 -- If (sx,sy) unifies with (tx,ty), take the subst S
 
--- 'qtvs' are the quantified type variables, the ones which an be instantiated
+-- 'qtvs' are the quantified type variables, the ones which can be instantiated
 -- to make the types match.  For example, given
 --      class C a b | a->b where ...
 --      instance C (Maybe x) (Tree x) where ..
@@ -281,7 +283,14 @@ improveClsFD clas_tvs fd
                   -> []
 
                   | otherwise
-                  -> [(meta_tvs, fdeqs)]
+                  -> -- pprTrace "iproveClsFD" (vcat
+                     --  [ text "is_tvs =" <+> ppr qtvs
+                     --  , text "tys_inst =" <+> ppr tys_inst
+                     --  , text "tys_actual =" <+> ppr tys_actual
+                     --  , text "ltys1 =" <+> ppr ltys1
+                     --  , text "ltys2 =" <+> ppr ltys2
+                     --  , text "subst =" <+> ppr subst ]) $
+                     [(meta_tvs, fdeqs)]
                         -- We could avoid this substTy stuff by producing the eqn
                         -- (qtvs, ls1++rs1, ls2++rs2)
                         -- which will re-do the ls1/ls2 unification when the equation is
@@ -532,7 +541,7 @@ oclose preds fixed_tvs
   | null tv_fds = fixed_tvs -- Fast escape hatch for common case.
   | otherwise   = fixVarSet extend fixed_tvs
   where
-    extend fixed_tvs = foldl add fixed_tvs tv_fds
+    extend fixed_tvs = foldl' add fixed_tvs tv_fds
        where
           add fixed_tvs (ls,rs)
             | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs
@@ -643,7 +652,7 @@ checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls
                    | otherwise                = Skolem
 
     eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2
-        -- An single instance may appear twice in the un-nubbed conflict list
+        -- A single instance may appear twice in the un-nubbed conflict list
         -- because it may conflict with more than one fundep.  E.g.
         --      class C a b c | a -> b, a -> c
         --      instance C Int Bool Bool
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 20c3d5cbb9..4f380d37a8 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -12,10 +12,10 @@ The @Inst@ type: dictionaries or method instances
 module Inst (
        deeplySkolemise,
        topInstantiate, topInstantiateInferred, deeplyInstantiate,
-       instCall, instDFunType, instStupidTheta,
+       instCall, instDFunType, instStupidTheta, instTyVarsWith,
        newWanted, newWanteds,
 
-       tcInstBinders, tcInstBinder,
+       tcInstTyBinders, tcInstTyBinder,
 
        newOverloadedLit, mkOverLit,
 
@@ -32,8 +32,10 @@ module Inst (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
-import {-# SOURCE #-}   TcUnify( unifyType, unifyKind, noThing )
+import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )
 
 import BasicTypes ( IntegralLit(..), SourceText(..) )
 import FastString
@@ -43,21 +45,21 @@ import TcRnMonad
 import TcEnv
 import TcEvidence
 import InstEnv
-import TysWiredIn  ( heqDataCon, coercibleDataCon )
+import TysWiredIn  ( heqDataCon, eqDataCon )
 import CoreSyn     ( isOrphan )
 import FunDeps
 import TcMType
 import Type
-import TyCoRep     ( TyBinder(..) )
+import TyCoRep
 import TcType
 import HscTypes
 import Class( Class )
 import MkId( mkDictFunId )
+import CoreSyn( Expr(..) )  -- For the Coercion constructor
 import Id
 import Name
-import Var      ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) )
+import Var      ( EvVar, mkTyVar, tyVarName, VarBndr(..) )
 import DataCon
-import TyCon
 import VarEnv
 import PrelNames
 import SrcLoc
@@ -95,7 +97,7 @@ newMethodFromName origin name inst_ty
        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
                  instCall origin [inst_ty] theta
 
-       ; return (mkHsWrap wrap (HsVar (noLoc id))) }
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
 
 {-
 ************************************************************************
@@ -196,15 +198,16 @@ top_instantiate inst_all orig ty
        ; let inst_theta' = substTheta subst inst_theta
              sigma'      = substTy subst (mkForAllTys leave_bndrs $
                                           mkFunTys leave_theta rho)
+             inst_tv_tys' = mkTyVarTys inst_tvs'
 
-       ; wrap1 <- instCall orig (mkTyVarTys inst_tvs') inst_theta'
+       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
        ; traceTc "Instantiating"
                  (vcat [ text "all tyvars?" <+> ppr inst_all
                        , text "origin" <+> pprCtOrigin orig
-                       , text "type" <+> ppr ty
+                       , text "type" <+> debugPprType ty
                        , text "theta" <+> ppr theta
                        , text "leave_bndrs" <+> ppr leave_bndrs
-                       , text "with" <+> ppr inst_tvs'
+                       , text "with" <+> vcat (map debugPprType inst_tv_tys')
                        , text "theta:" <+>  ppr inst_theta' ])
 
        ; (wrap2, rho2) <-
@@ -220,7 +223,7 @@ top_instantiate inst_all orig ty
 
   | otherwise = return (idHsWrapper, ty)
   where
-    (binders, phi) = tcSplitForAllTyVarBndrs ty
+    (binders, phi) = tcSplitForAllVarBndrs ty
     (theta, rho)   = tcSplitPhiTy phi
 
     should_inst bndr
@@ -254,8 +257,9 @@ deeply_instantiate :: CtOrigin
 deeply_instantiate orig subst ty
   | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
   = do { (subst', tvs') <- newMetaTyVarsX subst tvs
-       ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst' arg_tys)
-       ; let theta' = substTheta subst' theta
+       ; let arg_tys' = substTys   subst' arg_tys
+             theta'   = substTheta subst' theta
+       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
        ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
        ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
                                                 , text "type" <+> ppr ty
@@ -268,7 +272,7 @@ deeply_instantiate orig subst ty
                     <.> wrap2
                     <.> wrap1
                     <.> mkWpEvVarApps ids1,
-                 mkFunTys arg_tys rho2) }
+                 mkFunTys arg_tys' rho2) }
 
   | otherwise
   = do { let ty' = substTy subst ty
@@ -279,6 +283,32 @@ deeply_instantiate orig subst ty
                        , text "subst:"    <+> ppr subst ])
       ; return (idHsWrapper, ty') }
 
+
+instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
+-- Use this when you want to instantiate (forall a b c. ty) with
+-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
+-- not yet match (perhaps because there are unsolved constraints; Trac #14154)
+-- If they don't match, emit a kind-equality to promise that they will
+-- eventually do so, and thus make a kind-homongeneous substitution.
+instTyVarsWith orig tvs tys
+  = go empty_subst tvs tys
+  where
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))
+
+    go subst [] []
+      = return subst
+    go subst (tv:tvs) (ty:tys)
+      | tv_kind `tcEqType` ty_kind
+      = go (extendTCvSubst subst tv ty) tvs tys
+      | otherwise
+      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
+           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
+      where
+        tv_kind = substTy subst (tyVarKind tv)
+        ty_kind = typeKind ty
+
+    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -322,16 +352,17 @@ instCallConstraints orig preds
        ; traceTc "instCallConstraints" (ppr evs)
        ; return (mkWpEvApps evs) }
   where
+    go :: TcPredType -> TcM EvTerm
     go pred
      | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
-     = do  { co <- unifyType noThing ty1 ty2
-           ; return (EvCoercion co) }
+     = do  { co <- unifyType Nothing ty1 ty2
+           ; return (evCoercion co) }
 
        -- Try short-cut #2
      | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
      , tc `hasKey` heqTyConKey
-     = do { co <- unifyType noThing ty1 ty2
-          ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }
+     = do { co <- unifyType Nothing ty1 ty2
+          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
 
      | otherwise
      = emitWanted orig pred
@@ -341,10 +372,14 @@ instDFunType :: DFunId -> [DFunInstType]
                     , TcThetaType ) -- instantiated constraint
 -- See Note [DFunInstType: instantiating types] in InstEnv
 instDFunType dfun_id dfun_inst_tys
-  = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys
+  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
        ; return (inst_tys, substTheta subst dfun_theta) }
   where
-    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
+    dfun_ty = idType dfun_id
+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
+                  -- With quantified constraints, the
+                  -- type of a dfun may not be closed
 
     go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
     go subst [] [] = return (subst, [])
@@ -374,25 +409,97 @@ instStupidTheta orig theta
 *                                                                      *
 ************************************************************************
 
+Note [Constraints handled in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally, we cannot handle constraints written in types. For example,
+if we declare
+
+  data C a where
+    MkC :: Show a => a -> C a
+
+we will not be able to use MkC in types, as we have no way of creating
+a type-level Show dictionary.
+
+However, we make an exception for equality types. Consider
+
+  data T1 a where
+    MkT1 :: T1 Bool
+
+  data T2 a where
+    MkT2 :: a ~ Bool => T2 a
+
+MkT1 has a constrained return type, while MkT2 uses an explicit equality
+constraint. These two types are often written interchangeably, with a
+reasonable expectation that they mean the same thing. For this to work --
+and for us to be able to promote GADTs -- we need to be able to instantiate
+equality constraints in types.
+
+One wrinkle is that the equality in MkT2 is *lifted*. But, for proper
+GADT equalities, GHC produces *unlifted* constraints. (This unlifting comes
+from DataCon.eqSpecPreds, which uses mkPrimEqPred.) And, perhaps a wily
+user will use (~~) for a heterogeneous equality. We thus must support
+all of (~), (~~), and (~#) in types. (See Note [The equality types story]
+in TysPrim for a primer on these equality types.)
+
+The get_eq_tys_maybe function recognizes these three forms of equality,
+returning a suitable type formation function and the two types related
+by the equality constraint. In the lifted case, it uses mkHEqBoxTy or
+mkEqBoxTy, which promote the datacons of the (~~) or (~) datatype,
+respectively.
+
+One might reasonably wonder who *unpacks* these boxes once they are
+made. After all, there is no type-level `case` construct. The surprising
+answer is that no one ever does. Instead, if a GADT constructor is used
+on the left-hand side of a type family equation, that occurrence forces
+GHC to unify the types in question. For example:
+
+  data G a where
+    MkG :: G Bool
+
+  type family F (x :: G a) :: a where
+    F MkG = False
+
+When checking the LHS `F MkG`, GHC sees the MkG constructor and then must
+unify F's implicit parameter `a` with Bool. This succeeds, making the equation
+
+    F Bool (MkG @Bool <Bool>) = False
+
+Note that we never need unpack the coercion. This is because type family
+equations are *not* parametric in their kind variables. That is, we could have
+just said
+
+  type family H (x :: G a) :: a where
+    H _ = False
+
+The presence of False on the RHS also forces `a` to become Bool, giving us
+
+    H Bool _ = False
+
+The fact that any of this works stems from the lack of phase separation between
+types and kinds (unlike the very present phase separation between terms and types).
+
+Once we have the ability to pattern-match on types below top-level, this will
+no longer cut it, but it seems fine for now.
+
 -}
 
 ---------------------------
 -- | This is used to instantiate binders when type-checking *types* only.
 -- The @VarEnv Kind@ gives some known instantiations.
 -- See also Note [Bidirectional type checking]
-tcInstBinders :: TCvSubst -> Maybe (VarEnv Kind)
-               -> [TyBinder] -> TcM (TCvSubst, [TcType])
-tcInstBinders subst mb_kind_info bndrs
-  = do { (subst, args) <- mapAccumLM (tcInstBinder mb_kind_info) subst bndrs
+tcInstTyBinders :: TCvSubst -> Maybe (VarEnv Kind)
+                -> [TyBinder] -> TcM (TCvSubst, [TcType])
+tcInstTyBinders subst mb_kind_info bndrs
+  = do { (subst, args) <- mapAccumLM (tcInstTyBinder mb_kind_info) subst bndrs
        ; traceTc "instantiating tybinders:"
            (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)
                            bndrs args)
        ; return (subst, args) }
 
 -- | Used only in *types*
-tcInstBinder :: Maybe (VarEnv Kind)
-              -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
-tcInstBinder mb_kind_info subst (Named (TvBndr tv _))
+tcInstTyBinder :: Maybe (VarEnv Kind)
+               -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
+tcInstTyBinder mb_kind_info subst (Named (Bndr tv _))
   = case lookup_tv tv of
       Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
       Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
@@ -402,22 +509,16 @@ tcInstBinder mb_kind_info subst (Named (TvBndr tv _))
                       ; lookupVarEnv env tv }
 
 
-tcInstBinder _ subst (Anon ty)
+tcInstTyBinder _ subst (Anon ty)
      -- This is the *only* constraint currently handled in types.
-  | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
-  = do { let origin = TypeEqOrigin { uo_actual   = k1
-                                   , uo_expected = k2
-                                   , uo_thing    = Nothing }
-       ; co <- case role of
-                 Nominal          -> unifyKind noThing k1 k2
-                 Representational -> emitWantedEq origin KindLevel role k1 k2
-                 Phantom          -> pprPanic "tcInstBinder Phantom" (ppr ty)
-       ; arg' <- mk co k1 k2
+  | Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty
+  = do { co <- unifyKind Nothing k1 k2
+       ; arg' <- mk co
        ; return (subst, arg') }
 
   | isPredTy substed_ty
   = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
-       ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)
+       ; addErrTcM (env, text "Illegal constraint in a kind:" <+> ppr tidy_ty)
 
          -- just invent a new variable so that we can continue
        ; u <- newUnique
@@ -432,22 +533,33 @@ tcInstBinder _ subst (Anon ty)
   where
     substed_ty = substTy subst ty
 
-      -- handle boxed equality constraints, because it's so easy
-    get_pred_tys_maybe ty
-      | Just (r, k1, k2) <- getEqPredTys_maybe ty
-      = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)
+      -- See Note [Constraints handled in types]
+    get_eq_tys_maybe :: Type
+                     -> Maybe ( Coercion -> TcM Type
+                                 -- given a coercion proving t1 ~# t2, produce the
+                                 -- right instantiation for the TyBinder at hand
+                              , Type  -- t1
+                              , Type  -- t2
+                              )
+    get_eq_tys_maybe ty
+        -- unlifted equality (~#)
+      | Just (Nominal, k1, k2) <- getEqPredTys_maybe ty
+      = Just (\co -> return $ mkCoercionTy co, k1, k2)
+
+        -- lifted heterogeneous equality (~~)
       | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
       = if | tc `hasKey` heqTyConKey
-             -> Just (mkHEqBoxTy, Nominal, k1, k2)
+             -> Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
            | otherwise
              -> Nothing
+
+        -- lifted homogeneous equality (~)
       | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
       = if | tc `hasKey` eqTyConKey
-             -> Just (mkEqBoxTy, Nominal, k1, k2)
-           | tc `hasKey` coercibleTyConKey
-             -> Just (mkCoercibleBoxTy, Representational, k1, k2)
+             -> Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
            | otherwise
              -> Nothing
+
       | otherwise
       = Nothing
 
@@ -464,19 +576,8 @@ mkHEqBoxTy co ty1 ty2
 -- | This takes @a ~# b@ and returns @a ~ b@.
 mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
 mkEqBoxTy co ty1 ty2
-  = do { eq_tc <- tcLookupTyCon eqTyConName
-       ; let [datacon] = tyConDataCons eq_tc
-       ; hetero <- mkHEqBoxTy co ty1 ty2
-       ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }
-  where k = typeKind ty1
-
--- | This takes @a ~R# b@ and returns @Coercible a b@.
-mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type
--- monadic just for convenience with mkEqBoxTy
-mkCoercibleBoxTy co ty1 ty2
-  = do { return $
-         mkTyConApp (promoteDataCon coercibleDataCon)
-                    [k, ty1, ty2, mkCoercionTy co] }
+  = return $
+    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
   where k = typeKind ty1
 
 {-
@@ -500,7 +601,7 @@ newOverloadedLit :: HsOverLit GhcRn
                  -> ExpRhoType
                  -> TcM (HsOverLit GhcTcId)
 newOverloadedLit
-  lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
+  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
   | not rebindable
     -- all built-in overloaded lits are tau-types, so we can just
     -- tauify the ExpType
@@ -511,8 +612,8 @@ newOverloadedLit
         -- Reason: If we do, tcSimplify will call lookupInst, which
         --         will call tcSyntaxName, which does unification,
         --         which tcSimplify doesn't like
-           Just expr -> return (lit { ol_witness = expr, ol_type = res_ty
-                                    , ol_rebindable = False })
+           Just expr -> return (lit { ol_witness = expr
+                                    , ol_ext = OverLitTc False res_ty })
            Nothing   -> newNonTrivialOverloadedLit orig lit
                                                    (mkCheckExpType res_ty) }
 
@@ -520,6 +621,7 @@ newOverloadedLit
   = newNonTrivialOverloadedLit orig lit res_ty
   where
     orig = LiteralOrigin lit
+newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
 
 -- Does not handle things that 'shortCutLit' can handle. See also
 -- newOverloadedLit in TcUnify
@@ -528,8 +630,8 @@ newNonTrivialOverloadedLit :: CtOrigin
                            -> ExpRhoType
                            -> TcM (HsOverLit GhcTcId)
 newNonTrivialOverloadedLit orig
-  lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name)
-               , ol_rebindable = rebindable }) res_ty
+  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
+               , ol_ext = rebindable }) res_ty
   = do  { hs_lit <- mkOverLit val
         ; let lit_ty = hsLitType hs_lit
         ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
@@ -538,23 +640,22 @@ newNonTrivialOverloadedLit orig
         ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
         ; res_ty <- readExpType res_ty
         ; return (lit { ol_witness = witness
-                      , ol_type = res_ty
-                      , ol_rebindable = rebindable }) }
+                      , ol_ext = OverLitTc rebindable res_ty }) }
 newNonTrivialOverloadedLit _ lit _
   = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
 
 ------------
-mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p)
+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
 mkOverLit (HsIntegral i)
   = do  { integer_ty <- tcMetaTy integerTyConName
-        ; return (HsInteger (setSourceText $ il_text i)
+        ; return (HsInteger (il_text i)
                             (il_value i) integer_ty) }
 
 mkOverLit (HsFractional r)
   = do  { rat_ty <- tcMetaTy rationalTyConName
-        ; return (HsRat def r rat_ty) }
+        ; return (HsRat noExt r rat_ty) }
 
-mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s)
+mkOverLit (HsIsString src s) = return (HsString src s)
 
 {-
 ************************************************************************
@@ -596,7 +697,7 @@ tcSyntaxName :: CtOrigin
 -- USED ONLY FOR CmdTop (sigh) ***
 -- See Note [CmdSyntaxTable] in HsExpr
 
-tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
+tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
   | std_nm == user_nm
   = do rhs <- newMethodFromName orig std_nm ty
        return (std_nm, rhs)
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index 2c587e213f..60872f749e 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -10,6 +10,8 @@
 
 module TcAnnotations ( tcAnnotations, annCtxt ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TcSplice ( runAnnotation )
 import Module
 import DynFlags
@@ -49,7 +51,7 @@ tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
 tcAnnotations' anns = mapM tcAnnotation anns
 
 tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
-tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
+tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
     -- Work out what the full target of this annotation was
     mod <- getModule
     let target = annProvenanceToTarget mod provenance
@@ -63,6 +65,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
     where
       safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."
                   , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]
+tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"
 
 annProvenanceToTarget :: Module -> AnnProvenance Name
                       -> AnnTarget Name
@@ -70,6 +73,6 @@ annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
 annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
 annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
 
-annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc
+annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
 annCtxt ann
   = hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index b72b9b193c..96adf46db8 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -10,6 +10,8 @@ Typecheck arrow notation
 
 module TcArrows ( tcProc ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )
 
 import HsSyn
@@ -119,11 +121,13 @@ tcCmdTop :: CmdEnv
          -> CmdType
          -> TcM (LHsCmdTop GhcTcId)
 
-tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty)
+tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
   = setSrcSpan loc $
     do  { cmd'   <- tcCmd env cmd cmd_ty
         ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
-        ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"
+
 ----------------------------------------
 tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
         -- The main recursive function
@@ -133,35 +137,35 @@ tcCmd env (L loc cmd) res_ty
         ; return (L loc cmd') }
 
 tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
-tc_cmd env (HsCmdPar cmd) res_ty
+tc_cmd env (HsCmdPar x cmd) res_ty
   = do  { cmd' <- tcCmd env cmd res_ty
-        ; return (HsCmdPar cmd') }
+        ; return (HsCmdPar x cmd') }
 
-tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty
+tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
   = do  { (binds', body') <- tcLocalBinds binds         $
                              setSrcSpan body_loc        $
                              tc_cmd env body res_ty
-        ; return (HsCmdLet (L l binds') (L body_loc body')) }
+        ; return (HsCmdLet x (L l binds') (L body_loc body')) }
 
-tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
+tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
       (scrut', scrut_ty) <- tcInferRho scrut
       matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
-      return (HsCmdCase scrut' matches')
+      return (HsCmdCase x scrut' matches')
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
                               ; tcCmd env body (stk, res_ty') }
 
-tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf Nothing pred' b1' b2')
+        ; return (HsCmdIf x Nothing pred' b1' b2')
     }
 
-tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
   = do  { pred_ty <- newOpenFlexiTyVarTy
         -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
         -- because we're going to apply it to the environment, not
@@ -177,7 +181,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
 
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf (Just fun') pred' b1' b2')
+        ; return (HsCmdIf x (Just fun') pred' b1' b2')
     }
 
 -------------------------------------------
@@ -196,7 +200,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
 --
 -- (plus -<< requires ArrowApply)
 
-tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
+tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; let fun_ty = mkCmdArrTy env arg_ty res_ty
@@ -204,7 +208,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
 
         ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
 
-        ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
+        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
   where
        -- Before type-checking f, use the environment of the enclosing
        -- proc for the (-<) case.
@@ -223,12 +227,12 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
 -- -----------------------------
 -- D;G |-a cmd exp : stk --> res
 
-tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
         ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
-        ; return (HsCmdApp fun' arg') }
+        ; return (HsCmdApp x fun' arg') }
 
 -------------------------------------------
 --              Lambda
@@ -238,9 +242,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
 -- D;G |-a (\x.cmd) : (t,stk) --> res
 
 tc_cmd env
-       (HsCmdLam (MG { mg_alts = L l [L mtch_loc
-                                   (match@(Match _ pats _maybe_rhs_sig grhss))],
-                       mg_origin = origin }))
+       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
+                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],
+                         mg_origin = origin }))
        (cmd_stk, res_ty)
   = addErrCtxt (pprMatchInCtxt match)        $
     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
@@ -250,34 +254,39 @@ tc_cmd env
                              tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
                              tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
 
-        ; let match' = L mtch_loc (Match LambdaExpr pats' Nothing grhss')
+        ; let match' = L mtch_loc (Match { m_ext = noExt
+                                         , m_ctxt = LambdaExpr, m_pats = pats'
+                                         , m_grhss = grhss' })
               arg_tys = map hsLPatType pats'
-              cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys
-                                  , mg_res_ty = res_ty, mg_origin = origin })
+              cmd' = HsCmdLam x (MG { mg_alts = L l [match']
+                                    , mg_ext = MatchGroupTc arg_tys res_ty
+                                    , mg_origin = origin })
         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
   where
     n_pats     = length pats
     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
     pg_ctxt    = PatGuard match_ctxt
 
-    tc_grhss (GRHSs grhss (L l binds)) stk_ty res_ty
+    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
         = do { (binds', grhss') <- tcLocalBinds binds $
                                    mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
-             ; return (GRHSs grhss' (L l binds')) }
+             ; return (GRHSs x grhss' (L l binds')) }
+    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"
 
-    tc_grhs stk_ty res_ty (GRHS guards body)
+    tc_grhs stk_ty res_ty (GRHS x guards body)
         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
                                   \ res_ty -> tcCmd env body
                                                 (stk_ty, checkingExpType "tc_grhs" res_ty)
-             ; return (GRHS guards' rhs') }
+             ; return (GRHS x guards' rhs') }
+    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"
 
 -------------------------------------------
 --              Do notation
 
-tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
-  = do  { co <- unifyType noThing unitTy cmd_stk  -- Expecting empty argument stack
+tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
+  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
         ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
-        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) }
+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
 
 
 -----------------------------------------------------------------
@@ -294,7 +303,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
 --      ----------------------------------------------
 --      D; G |-a  (| e c1 ... cn |)  :  stk --> t
 
-tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
                               -- We use alphaTyVar for 'w'
@@ -302,7 +311,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
                      mkFunTys cmd_tys $
                      mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
         ; expr' <- tcPolyExpr expr e_ty
-        ; return (HsCmdArrForm expr' f fixity cmd_args') }
+        ; return (HsCmdArrForm x expr' f fixity cmd_args') }
 
   where
     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
@@ -314,6 +323,8 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
             ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
 
+tc_cmd _ (XCmd {}) _ = panic "tc_cmd"
+
 -----------------------------------------------------------------
 --              Base case for illegal commands
 -- This is where expressions that aren't commands get rejected
@@ -346,17 +357,17 @@ matchExpectedCmdArgs n ty
 --      (b) no rebindable syntax
 
 tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
-tcArrDoStmt env _ (LastStmt rhs noret _) res_ty thing_inside
+tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
   = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
         ; thing <- thing_inside (panic "tcArrDoStmt")
-        ; return (LastStmt rhs' noret noSyntaxExpr, thing) }
+        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }
 
-tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside
+tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
   = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
         ; thing          <- thing_inside res_ty
-        ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
+        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
+tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                             thing_inside res_ty
@@ -388,10 +399,11 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 
         ; return (emptyRecStmtId { recS_stmts = stmts'
                                  , recS_later_ids = later_ids
-                                 , recS_later_rets = later_rets
                                  , recS_rec_ids = rec_ids
-                                 , recS_rec_rets = rec_rets
-                                 , recS_ret_ty = res_ty }, thing)
+                                 , recS_ext = unitRecStmtTc
+                                     { recS_later_rets = later_rets
+                                     , recS_rec_rets = rec_rets
+                                     , recS_ret_ty = res_ty} }, thing)
         }}
 
 tcArrDoStmt _ _ stmt _ _
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index a4b31db93a..31055fdb7c 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -17,6 +17,8 @@ module TcBackpack (
     instantiateSignature,
 ) where
 
+import GhcPrelude
+
 import BasicTypes (defaultFixity)
 import Packages
 import TcRnExports
@@ -158,7 +160,7 @@ checkHsigIface tcg_env gr sig_iface
             -- TODO: Actually this error swizzle doesn't work
             let p (L _ ie) = name `elem` ieNames ie
                 loc = case tcg_rn_exports tcg_env of
-                       Just es | Just e <- find p es
+                       Just es | Just e <- find p (map fst es)
                          -- TODO: maybe we can be a little more
                          -- precise here and use the Located
                          -- info for the *specific* name we matched.
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 7b01ababcd..b549856ac1 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -9,18 +9,19 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
+module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
                  tcHsBootSigs, tcPolyCheck,
-                 tcVectDecls, addTypecheckedBinds,
+                 addTypecheckedBinds,
                  chooseInferredQuantifiers,
                  badBootDeclErr ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
-import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
-                               , tcPatSynBuilderBind )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
 import CoreSyn (Tickish (..))
-import CostCentre (mkUserCC)
+import CostCentre (mkUserCC, CCFlavour(DeclCC))
 import DynFlags
 import FastString
 import HsSyn
@@ -38,9 +39,9 @@ import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
 import TyCon
 import TcType
-import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe)
+import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
 import TysPrim
-import TysWiredIn( cTupleTyConName )
+import TysWiredIn( mkBoxedTupleTy )
 import Id
 import Var
 import VarSet
@@ -51,7 +52,6 @@ import NameSet
 import NameEnv
 import SrcLoc
 import Bag
-import ListSetOps
 import ErrUtils
 import Digraph
 import Maybes
@@ -60,7 +60,6 @@ import BasicTypes
 import Outputable
 import PrelNames( ipClassName )
 import TcValidity (checkValidType)
-import Unique (getUnique)
 import UniqFM
 import UniqSet
 import qualified GHC.LanguageExtensions as LangExt
@@ -137,7 +136,7 @@ If we don't take care, after typechecking we get
                                in
                                \ys:[a] -> ...f'...
 
-Notice the the stupid construction of (f a d), which is of course
+Notice the stupid construction of (f a d), which is of course
 identical to the function we're executing.  In this case, the
 polymorphic recursion isn't being used (but that's a very common case).
 This can lead to a massive space leak, from the following top-level defn
@@ -233,7 +232,7 @@ tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
 tcCompleteSigs sigs =
   let
       doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
-      doOne c@(CompleteMatchSig _ lns mtc)
+      doOne c@(CompleteMatchSig _ _ lns mtc)
         = fmap Just $ do
            addErrCtxt (text "In" <+> ppr c) $
             case mtc of
@@ -304,15 +303,6 @@ tcCompleteSigs sigs =
                                <+> quotes (ppr tc'))
   in  mapMaybeM (addLocM doOne) sigs
 
-tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
-tcRecSelBinds (ValBindsOut binds sigs)
-  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
-    do { (rec_sel_binds, tcg_env) <- discardWarnings $
-                                     tcValBinds TopLevel binds sigs getGblEnv
-       ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
-       ; return tcg_env' }
-tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
-
 tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
@@ -320,7 +310,7 @@ tcHsBootSigs binds sigs
   = do  { checkTc (null binds) badBootDeclErr
         ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
   where
-    tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
+    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
       where
         f (L _ name)
           = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
@@ -335,16 +325,16 @@ badBootDeclErr = text "Illegal declarations in an hs-boot file"
 tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
              -> TcM (HsLocalBinds GhcTcId, thing)
 
-tcLocalBinds EmptyLocalBinds thing_inside
+tcLocalBinds (EmptyLocalBinds x) thing_inside
   = do  { thing <- thing_inside
-        ; return (EmptyLocalBinds, thing) }
+        ; return (EmptyLocalBinds x, thing) }
 
-tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
+tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
   = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
-        ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
-tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
+        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
 
-tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
+tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
   = do  { ipClass <- tcLookupClass ipClassName
         ; (given_ips, ip_binds') <-
             mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
@@ -355,27 +345,31 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
         ; (ev_binds, result) <- checkConstraints (IPSkol ips)
                                   [] given_ips thing_inside
 
-        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
+        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
   where
-    ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
+    ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds]
 
         -- I wonder if we should do these one at at time
         -- Consider     ?x = 4
         --              ?y = ?x + 1
-    tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
+    tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)
        = do { ty <- newOpenFlexiTyVarTy
             ; let p = mkStrLitTy $ hsIPNameFS ip
             ; ip_id <- newDict ipClass [ p, ty ]
             ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
             ; let d = toDict ipClass p ty `fmap` expr'
-            ; return (ip_id, (IPBind (Right ip_id) d)) }
-    tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
+            ; return (ip_id, (IPBind noExt (Right ip_id) d)) }
+    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
+    tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"
 
     -- Coerces a `t` into a dictionry for `IP "x" t`.
     -- co : t -> IP "x" t
     toDict ipClass x ty = mkHsWrap $ mkWpCastR $
                           wrapIP $ mkClassPred ipClass [x,ty]
 
+tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
+tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"
+
 {- Note [Implicit parameter untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We add the type variables in the types of the implicit parameters
@@ -407,7 +401,7 @@ tcValBinds top_lvl binds sigs thing_inside
 
                 -- Extend the envt right away with all the Ids
                 -- declared with complete type signatures
-                -- Do not extend the TcIdBinderStack; instead
+                -- Do not extend the TcBinderStack; instead
                 -- we extend it on a per-rhs basis in tcExtendForRhs
         ; tcExtendSigIds top_lvl poly_ids $ do
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
@@ -529,18 +523,12 @@ tc_single :: forall thing.
           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
           -> TcM (LHsBinds GhcTcId, thing)
 tc_single _top_lvl sig_fn _prag_fn
-          (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
+          (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
           _ thing_inside
-  = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
        ; thing <- setGblEnv tcg_env thing_inside
        ; return (aux_binds, thing)
        }
-  where
-    tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv)
-    tc_pat_syn_decl = case sig_fn name of
-        Nothing                 -> tcInferPatSynDecl psb
-        Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
-        Just                 _  -> panic "tc_single"
 
 tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
   = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
@@ -564,6 +552,10 @@ mkEdges sig_fn binds
     -- is still deterministic even if the edges are in nondeterministic order
     -- as explained in Note [Deterministic SCC] in Digraph.
   where
+    bind_fvs (FunBind { fun_ext = fvs }) = fvs
+    bind_fvs (PatBind { pat_ext = fvs }) = fvs
+    bind_fvs _                           = emptyNameSet
+
     no_sig :: Name -> Bool
     no_sig n = not (hasCompleteSig sig_fn n)
 
@@ -638,7 +630,13 @@ recoveryCode binder_names sig_fn
       = mkLocalId name forall_a_a
 
 forall_a_a :: TcType
-forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
+-- At one point I had (forall r (a :: TYPE r). a), but of course
+-- that type is ill-formed: its mentions 'r' which escapes r's scope.
+-- Another alternative would be (forall (a :: TYPE kappa). a), where
+-- kappa is a unification variable. But I don't think we need that
+-- complication here. I'm going to just use (forall (a::*). a).
+-- See Trac #15276
+forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
 
 {- *********************************************************************
 *                                                                      *
@@ -701,8 +699,8 @@ tcPolyCheck prag_fn
 
        ; (ev_binds, (co_fn, matches'))
             <- checkConstraints skol_info skol_tvs ev_vars $
-               tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel]  $
-               tcExtendTyVarEnv2 tv_prs $
+               tcExtendBinderStack [TcIdBndr mono_id NotTopLevel]  $
+               tcExtendNameTyVarEnv tv_prs $
                setSrcSpan loc           $
                tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
 
@@ -711,19 +709,27 @@ tcPolyCheck prag_fn
        ; poly_id    <- addInlinePrags poly_id prag_sigs
 
        ; mod <- getModule
+       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
        ; let bind' = FunBind { fun_id      = L nm_loc mono_id
                              , fun_matches = matches'
                              , fun_co_fn   = co_fn
-                             , bind_fvs    = placeHolderNamesTc
-                             , fun_tick    = funBindTicks nm_loc mono_id mod prag_sigs }
+                             , fun_ext     = placeHolderNamesTc
+                             , fun_tick    = tick }
 
-             abs_bind = L loc $ AbsBindsSig
-                        { abs_sig_export  = poly_id
-                        , abs_tvs         = skol_tvs
-                        , abs_ev_vars     = ev_vars
-                        , abs_sig_prags   = SpecPrags spec_prags
-                        , abs_sig_ev_bind = ev_binds
-                        , abs_sig_bind    = L loc bind' }
+             export = ABE { abe_ext = noExt
+                          , abe_wrap = idHsWrapper
+                          , abe_poly  = poly_id
+                          , abe_mono  = mono_id
+                          , abe_prags = SpecPrags spec_prags }
+
+             abs_bind = L loc $
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs      = skol_tvs
+                                 , abs_ev_vars  = ev_vars
+                                 , abs_ev_binds = [ev_binds]
+                                 , abs_exports  = [export]
+                                 , abs_binds    = unitBag (L loc bind')
+                                 , abs_sig      = True }
 
        ; return (unitBag abs_bind, [poly_id]) }
 
@@ -731,9 +737,9 @@ tcPolyCheck _prag_fn sig bind
   = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
 
 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-             -> [Tickish TcId]
+             -> TcM [Tickish TcId]
 funBindTicks loc fun_id mod sigs
-  | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
+  | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
       -- this can only be a singleton list, as duplicate pragmas are rejected
       -- by the renamer
   , let cc_str
@@ -742,10 +748,12 @@ funBindTicks loc fun_id mod sigs
           | otherwise
           = getOccFS (Var.varName fun_id)
         cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
-        cc = mkUserCC cc_name mod loc (getUnique fun_id)
-  = [ProfNote cc True True]
+  = do
+      flavour <- DeclCC <$> getCCIndexM cc_name
+      let cc = mkUserCC cc_name mod loc flavour
+      return [ProfNote cc True True]
   | otherwise
-  = []
+  = return []
 
 {- Note [Instantiate sig with fresh variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -787,19 +795,21 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
        ; mapM_ (checkOverloadedSig mono) sigs
 
        ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
-       ; (qtvs, givens, ev_binds)
+       ; (qtvs, givens, ev_binds, insoluble)
                  <- simplifyInfer tclvl infer_mode sigs name_taus wanted
 
        ; let inferred_theta = map evVarPred givens
        ; exports <- checkNoErrs $
-                    mapM (mkExport prag_fn qtvs inferred_theta) mono_infos
+                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
 
        ; loc <- getSrcSpanM
        ; let poly_ids = map abe_poly exports
              abs_bind = L loc $
-                        AbsBinds { abs_tvs = qtvs
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs = qtvs
                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
-                                 , abs_exports = exports, abs_binds = binds' }
+                                 , abs_exports = exports, abs_binds = binds'
+                                 , abs_sig = False }
 
        ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
        ; return (unitBag abs_bind, poly_ids) }
@@ -807,6 +817,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
 
 --------------
 mkExport :: TcPragEnv
+         -> Bool                        -- True <=> there was an insoluble type error
+                                        --          when typechecking the bindings
          -> [TyVar] -> TcThetaType      -- Both already zonked
          -> MonoBindInfo
          -> TcM (ABExport GhcTc)
@@ -823,12 +835,12 @@ mkExport :: TcPragEnv
 
 -- Pre-condition: the qtvs and theta are already zonked
 
-mkExport prag_fn qtvs theta
+mkExport prag_fn insoluble qtvs theta
          mono_info@(MBI { mbi_poly_name = poly_name
                         , mbi_sig       = mb_sig
                         , mbi_mono_id   = mono_id })
   = do  { mono_ty <- zonkTcType (idType mono_id)
-        ; poly_id <- mkInferredPolyId qtvs theta poly_name mb_sig mono_ty
+        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
 
         -- NB: poly_id has a zonked type
         ; poly_id <- addInlinePrags poly_id prag_sigs
@@ -854,19 +866,22 @@ mkExport prag_fn qtvs theta
         ; when warn_missing_sigs $
               localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
 
-        ; return (ABE { abe_wrap = wrap
+        ; return (ABE { abe_ext = noExt
+                      , abe_wrap = wrap
                         -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
-                      , abe_poly = poly_id
-                      , abe_mono = mono_id
-                      , abe_prags = SpecPrags spec_prags}) }
+                      , abe_poly  = poly_id
+                      , abe_mono  = mono_id
+                      , abe_prags = SpecPrags spec_prags }) }
   where
     prag_sigs = lookupPragEnv prag_fn poly_name
     sig_ctxt  = InfSigCtxt poly_name
 
-mkInferredPolyId :: [TyVar] -> TcThetaType
+mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when
+                          --          checking the binding group for this Id
+                 -> [TyVar] -> TcThetaType
                  -> Name -> Maybe TcIdSigInst -> TcType
                  -> TcM TcId
-mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty
+mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
   | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst
   , CompleteSig { sig_bndr = poly_id } <- sig
   = return poly_id
@@ -894,9 +909,13 @@ mkInferredPolyId qtvs inferred_theta poly_name mb_sig_inst mono_ty
 
        ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
                                           , ppr inferred_poly_ty])
-       ; addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
+       ; unless insoluble $
+         addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
          checkValidType (InfSigCtxt poly_name) inferred_poly_ty
          -- See Note [Validity of inferred types]
+         -- If we found an insoluble error in the function definition, don't
+         -- do this check; otherwise (Trac #14000) we may report an ambiguity
+         -- error for a rather bogus type.
 
        ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
 
@@ -921,64 +940,96 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
                                       , sig_inst_wcx   = wcx
                                       , sig_inst_theta = annotated_theta
                                       , sig_inst_skols = annotated_tvs }))
-  | Nothing <- wcx
-  = do { annotated_theta <- zonkTcTypes annotated_theta
-       ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
-                                        `unionVarSet` tau_tvs)
-       ; traceTc "ciq" (vcat [ ppr sig, ppr annotated_theta, ppr free_tvs])
-       ; psig_qtvs <- mk_psig_qtvs annotated_tvs
-       ; return (mk_final_qtvs psig_qtvs free_tvs, annotated_theta) }
-
-  | Just wc_var <- wcx
-  = do { annotated_theta <- zonkTcTypes annotated_theta
-       ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
-                          -- growThetaVars just like the no-type-sig case
-                          -- Omitting this caused #12844
-             seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
-                        `unionVarSet` tau_tvs            --       by the user
-
-       ; psig_qtvs <- mk_psig_qtvs annotated_tvs
-       ; let my_qtvs  = mk_final_qtvs psig_qtvs free_tvs
-             keep_me  = psig_qtvs `unionVarSet` free_tvs
-             my_theta = pickCapturedPreds keep_me inferred_theta
-
-       -- Report the inferred constraints for an extra-constraints wildcard/hole as
-       -- an error message, unless the PartialTypeSignatures flag is enabled. In this
-       -- case, the extra inferred constraints are accepted without complaining.
-       -- NB: inferred_theta already includes all the annotated constraints
-             inferred_diff = [ pred
-                             | pred <- my_theta
-                             , all (not . (`eqType` pred)) annotated_theta ]
-       ; ctuple <- mk_ctuple inferred_diff
-       ; writeMetaTyVar wc_var ctuple
-       ; traceTc "completeTheta" $
-            vcat [ ppr sig
-                 , ppr annotated_theta, ppr inferred_theta
-                 , ppr inferred_diff ]
-
-       ; return (my_qtvs, my_theta) }
-
-  | otherwise  -- A complete type signature is dealt with in mkInferredPolyId
-  = pprPanic "chooseInferredQuantifiers" (ppr sig)
-
+  = -- Choose quantifiers for a partial type signature
+    do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs
+
+            -- Check whether the quantified variables of the
+            -- partial signature have been unified together
+            -- See Note [Quantified variables in partial type signatures]
+       ; mapM_ report_dup_tyvar_tv_err  (findDupTyVarTvs psig_qtv_prs)
+
+            -- Check whether a quantified variable of the partial type
+            -- signature is not actually quantified.  How can that happen?
+            -- See Note [Quantification and partial signatures] Wrinkle 4
+            --     in TcSimplify
+       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
+                                          , not (tv `elem` qtvs) ]
+
+       ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
+
+       ; annotated_theta      <- zonkTcTypes annotated_theta
+       ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
+
+       ; let keep_me    = free_tvs `unionVarSet` psig_qtvs
+             final_qtvs = [ mkTyVarBinder vis tv
+                          | tv <- qtvs -- Pulling from qtvs maintains original order
+                          , tv `elemVarSet` keep_me
+                          , let vis | tv `elemVarSet` psig_qtvs = Specified
+                                    | otherwise                 = Inferred ]
+
+       ; return (final_qtvs, my_theta) }
   where
-    mk_final_qtvs psig_qtvs free_tvs
-      = [ mkTyVarBinder vis tv
-        | tv <- qtvs -- Pulling from qtvs maintains original order
-        , tv `elemVarSet` keep_me
-        , let vis | tv `elemVarSet` psig_qtvs = Specified
-                  | otherwise                 = Inferred ]
-      where
-        keep_me = free_tvs `unionVarSet` psig_qtvs
-
-    mk_ctuple [pred] = return pred
-    mk_ctuple preds  = do { tc <- tcLookupTyCon (cTupleTyConName (length preds))
-                          ; return (mkTyConApp tc preds) }
+    report_dup_tyvar_tv_err (n1,n2)
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+                     2 (hang (text "both bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_tyvar_tv_err" (ppr sig)
+
+    report_mono_sig_tv_err n
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
+                     2 (hang (text "bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_mono_sig_tv_err" (ppr sig)
+
+    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
+                        -> TcM (VarSet, TcThetaType)
+    choose_psig_context _ annotated_theta Nothing
+      = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
+                                            `unionVarSet` tau_tvs)
+           ; return (free_tvs, annotated_theta) }
+
+    choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
+      = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
+                            -- growThetaVars just like the no-type-sig case
+                            -- Omitting this caused #12844
+                 seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
+                            `unionVarSet` tau_tvs            --       by the user
+
+           ; let keep_me  = psig_qtvs `unionVarSet` free_tvs
+                 my_theta = pickCapturedPreds keep_me inferred_theta
+
+           -- Fill in the extra-constraints wildcard hole with inferred_theta,
+           -- so that the Hole constraint we have already emitted
+           -- (in tcHsPartialSigType) can report what filled it in.
+           -- NB: my_theta already includes all the annotated constraints
+           ; let inferred_diff = [ pred
+                                 | pred <- my_theta
+                                 , all (not . (`eqType` pred)) annotated_theta ]
+           ; ctuple <- mk_ctuple inferred_diff
+
+           ; case tcGetCastedTyVar_maybe wc_var_ty of
+               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
+               -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
+               -- make the kinds work out, we reverse the cast here.
+               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
+               Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
+
+           ; traceTc "completeTheta" $
+                vcat [ ppr sig
+                     , ppr annotated_theta, ppr inferred_theta
+                     , ppr inferred_diff ]
+           ; return (free_tvs, my_theta) }
+
+    mk_ctuple preds = return (mkBoxedTupleTy preds)
+       -- Hack alert!  See TcHsType:
+       -- Note [Extra-constraint holes in partial type signatures]
 
-    mk_psig_qtvs :: [(Name,TcTyVar)] -> TcM TcTyVarSet
-    mk_psig_qtvs annotated_tvs
-       = do { psig_qtvs <- mapM (zonkTcTyVarToTyVar . snd) annotated_tvs
-            ; return (mkVarSet psig_qtvs) }
 
 mk_impedance_match_msg :: MonoBindInfo
                        -> TcType -> TcType
@@ -1076,6 +1127,28 @@ It's stupid to apply the MR here.  This test includes an extra-constraints
 wildcard; that is, we don't apply the MR if you write
    f3 :: _ => blah
 
+Note [Quantified variables in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: forall a. a -> a -> _
+  f x y = g x y
+  g :: forall b. b -> b -> _
+  g x y = [x, y]
+
+Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
+together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then
+unify with each other.
+
+But now consider:
+  f :: forall a b. a -> b -> _
+  f x y = [x, y]
+
+We want to get an error from this, because 'a' and 'b' get unified.
+So we make a test, one per parital signature, to check that the
+explicitly-quantified type variables have not been unified together.
+Trac #14449 showed this up.
+
+
 Note [Validity of inferred types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to check inferred type for validity, in case it uses language
@@ -1130,82 +1203,6 @@ It also cleverly does an ambiguity check; for example, rejecting
 where F is a non-injective type function.
 -}
 
-{- *********************************************************************
-*                                                                      *
-                         Vectorisation
-*                                                                      *
-********************************************************************* -}
-
-tcVectDecls :: [LVectDecl GhcRn] -> TcM ([LVectDecl GhcTcId])
-tcVectDecls decls
-  = do { decls' <- mapM (wrapLocM tcVect) decls
-       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
-             dups = findDupsEq (==) ids
-       ; mapM_ reportVectDups dups
-       ; traceTcConstraints "End of tcVectDecls"
-       ; return decls'
-       }
-  where
-    reportVectDups (first:_second:_more)
-      = addErrAt (getSrcSpan first) $
-          text "Duplicate vectorisation declarations for" <+> ppr first
-    reportVectDups _ = return ()
-
---------------
-tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId)
--- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
---   type of the original definition as this requires internals of the vectoriser not available
---   during type checking.  Instead, constrain the rhs of a vectorisation declaration to be a single
---   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
---   from the vectoriser here.
-tcVect (HsVect s name rhs)
-  = addErrCtxt (vectCtxt name) $
-    do { var <- wrapLocM tcLookupId name
-       ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs
-       ; rhs_id <- tcLookupId rhs_var_name
-       ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id)))
-       }
-
-tcVect (HsNoVect s name)
-  = addErrCtxt (vectCtxt name) $
-    do { var <- wrapLocM tcLookupId name
-       ; return $ HsNoVect s var
-       }
-tcVect (HsVectTypeIn _ isScalar lname rhs_name)
-  = addErrCtxt (vectCtxt lname) $
-    do { tycon <- tcLookupLocatedTyCon lname
-       ; checkTc (   not isScalar             -- either    we have a non-SCALAR declaration
-                 || isJust rhs_name           -- or        we explicitly provide a vectorised type
-                 || tyConArity tycon == 0     -- otherwise the type constructor must be nullary
-                 )
-                 scalarTyConMustBeNullary
-
-       ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
-       ; return $ HsVectTypeOut isScalar tycon rhs_tycon
-       }
-tcVect (HsVectTypeOut _ _ _)
-  = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
-tcVect (HsVectClassIn _ lname)
-  = addErrCtxt (vectCtxt lname) $
-    do { cls <- tcLookupLocatedClass lname
-       ; return $ HsVectClassOut cls
-       }
-tcVect (HsVectClassOut _)
-  = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
-tcVect (HsVectInstIn linstTy)
-  = addErrCtxt (vectCtxt linstTy) $
-    do { (cls, tys) <- tcHsVectInst linstTy
-       ; inst       <- tcLookupInstance cls tys
-       ; return $ HsVectInstOut inst
-       }
-tcVect (HsVectInstOut _)
-  = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
-
-vectCtxt :: Outputable thing => thing -> SDoc
-vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing
-
-scalarTyConMustBeNullary :: MsgDoc
-scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary"
 
 {-
 Note [SPECIALISE pragmas]
@@ -1251,7 +1248,7 @@ tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking pur
             -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
 tcMonoBinds is_rec sig_fn no_gen
            [ L b_loc (FunBind { fun_id = L nm_loc name,
-                                fun_matches = matches, bind_fvs = fvs })]
+                                fun_matches = matches, fun_ext = fvs })]
                              -- Single function binding,
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
   , Nothing <- sig_fn name   -- ...with no type signature
@@ -1267,7 +1264,7 @@ tcMonoBinds is_rec sig_fn no_gen
             <- tcInferInst $ \ exp_ty ->
                   -- tcInferInst: see TcUnify,
                   -- Note [Deep instantiation of InferResult]
-               tcExtendIdBndrs [TcIdBndr_ExpType name exp_ty NotTopLevel] $
+               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
                   -- We extend the error context even for a non-recursive
                   -- function so that in type error messages we show the
                   -- type of the thing whose rhs we are type checking
@@ -1276,7 +1273,7 @@ tcMonoBinds is_rec sig_fn no_gen
         ; mono_id <- newLetBndr no_gen name rhs_ty
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
-                               fun_matches = matches', bind_fvs = fvs,
+                               fun_matches = matches', fun_ext = fvs,
                                fun_co_fn = co_fn, fun_tick = [] },
                   [MBI { mbi_poly_name = name
                        , mbi_sig       = Nothing
@@ -1424,7 +1421,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
         ; return ( FunBind { fun_id = L loc mono_id
                            , fun_matches = matches'
                            , fun_co_fn = co_fn
-                           , bind_fvs = placeHolderNamesTc
+                           , fun_ext = placeHolderNamesTc
                            , fun_tick = [] } ) }
 
 tcRhs (TcPatBind infos pat' grhss pat_ty)
@@ -1437,8 +1434,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                     tcGRHSsPat grhss pat_ty
         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
-                           , pat_rhs_ty = pat_ty
-                           , bind_fvs = placeHolderNamesTc
+                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
                            , pat_ticks = ([],[]) } )}
 
 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
@@ -1450,12 +1446,13 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside
 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
 tcExtendTyVarEnvFromSig sig_inst thing_inside
   | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
-  = tcExtendTyVarEnv2 wcs $
-    tcExtendTyVarEnv2 skol_prs $
+     -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
+  = tcExtendNameTyVarEnv wcs $
+    tcExtendNameTyVarEnv skol_prs $
     thing_inside
 
 tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
--- Extend the TcIdBinderStack for the RHS of the binding, with
+-- Extend the TcBinderStack for the RHS of the binding, with
 -- the monomorphic Id.  That way, if we have, say
 --     f = \x -> blah
 -- and something goes wrong in 'blah', we get a "relevant binding"
@@ -1464,12 +1461,12 @@ tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
 --    f :: forall a. [a] -> [a]
 --    f x = True
 -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
--- If we had the *polymorphic* version of f in the TcIdBinderStack, it
+-- If we had the *polymorphic* version of f in the TcBinderStack, it
 -- would not be reported as relevant, because its type is closed
 tcExtendIdBinderStackForRhs infos thing_inside
-  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
-                    | MBI { mbi_mono_id = mono_id } <- infos ]
-                    thing_inside
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | MBI { mbi_mono_id = mono_id } <- infos ]
+                        thing_inside
     -- NotTopLevel: it's a monomorphic binding
 
 ---------------------
@@ -1589,6 +1586,30 @@ Example for (E2), we generate
 The beta is untoucable, but floats out of the constraint and can
 be solved absolutely fine.
 
+Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, any place that corresponds to Λ or ∀ in Core should be flagged
+with a call to scopeTyVars, which arranges for an implication constraint
+to be made, bumps the TcLevel, and (crucially) prevents a unification
+variable created outside the scope of a local skolem to unify with that
+skolem.
+
+We do not need to do this here, however.
+
+- Note that this happens only in the case of a partial signature.
+  Complete signatures go via tcPolyCheck, not tcPolyInfer.
+
+- The TcLevel is incremented in tcPolyInfer, right outside the call
+  to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
+  with local skolems.
+
+- The other potential concern is that we need SkolemInfo associated with
+  the skolems. This, too, is OK, though: the constraints pass through
+  simplifyInfer (which doesn't report errors), at the end of which
+  the skolems will get quantified and put into an implication constraint.
+  Thus, by the time any errors are reported, the SkolemInfo will be
+  in place.
+
 ************************************************************************
 *                                                                      *
                 Generalisation
@@ -1603,7 +1624,7 @@ data GeneralisationPlan
 
   | CheckGen (LHsBind GhcRn) TcIdSigInfo
                         -- One FunBind with a signature
-                        -- Explicit generalisation; there is an AbsBindsSig
+                        -- Explicit generalisation
 
 -- A consequence of the no-AbsBinds choice (NoGen) is that there is
 -- no "polymorphic Id" and "monmomorphic Id"; there is just the one
@@ -1677,16 +1698,18 @@ isClosedBndrGroup type_env binds
     fv_env :: NameEnv NameSet
     fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
 
-    bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)]
-    bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs })
-       = let open_fvs = filterNameSet (not . is_closed) fvs
+    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
+    bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
          in [(f, open_fvs)]
-    bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
-       = let open_fvs = filterNameSet (not . is_closed) fvs
+    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
          in [(b, open_fvs) | b <- collectPatBinders pat]
     bindFvs _
        = []
 
+    get_open_fvs fvs = filterNameSet (not . is_closed) fvs
+
     is_closed :: Name -> ClosedTypeId
     is_closed name
       | Just thing <- lookupNameEnv type_env name
@@ -1725,7 +1748,7 @@ isClosedBndrGroup type_env binds
 
 -- This one is called on LHS, when pat and grhss are both Name
 -- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body)
-                 => LPat p -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
+                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
 patMonoBindsCtxt pat grhss
   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index be51914a27..6579556843 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -4,11 +4,14 @@ module TcCanonical(
      canonicalize,
      unifyDerived,
      makeSuperClasses, maybeSym,
-     StopOrContinue(..), stopWith, continueWith
+     StopOrContinue(..), stopWith, continueWith,
+     solveCallStack    -- For TcSimplify
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes
 import TcUnify( swapOverTyVars, metaTyVarUpdateOK )
 import TcType
@@ -16,19 +19,24 @@ import Type
 import TcFlatten
 import TcSMonad
 import TcEvidence
+import TcEvTerm
 import Class
 import TyCon
 import TyCoRep   -- cleverly decomposes types, good for completeness checking
+import TysWiredIn( cTupleTyConName )
 import Coercion
+import CoreSyn
+import Id( idType, mkTemplateLocals )
 import FamInstEnv ( FamInstEnvs )
 import FamInst ( tcTopNormaliseNewTypeTF_maybe )
 import Var
 import VarEnv( mkInScopeSet )
-import VarSet( extendVarSetList )
+import VarSet( delVarSetList )
 import Outputable
 import DynFlags( DynFlags )
 import NameSet
 import RdrName
+import HsTypes( HsIPName(..) )
 
 import Pair
 import Util
@@ -75,10 +83,34 @@ last time through, so we can skip the classification step.
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 canonicalize :: Ct -> TcS (StopOrContinue Ct)
-canonicalize ct@(CNonCanonical { cc_ev = ev })
-  = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
-       ; {-# SCC "canEvVar" #-}
-         canEvNC ev }
+canonicalize (CNonCanonical { cc_ev = ev })
+  = {-# SCC "canNC" #-}
+    case classifyPredType pred of
+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+                                  canClassNC ev cls tys
+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
+                                  canEqNC    ev eq_rel ty1 ty2
+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
+                                  canIrred ev
+      ForAllPred _ _ pred   -> do traceTcS "canEvNC:forall" (ppr pred)
+                                  canForAll ev (isClassPred pred)
+  where
+    pred = ctEvPred ev
+
+canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
+  = canForAll ev pend_sc
+
+canonicalize (CIrredCan { cc_ev = ev })
+  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)
+  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments
+    -- In Trac #14350 doing so led entire-unnecessary and ridiculously large
+    -- type function expansion.  Instead, canEqNC just applies
+    -- the substitution to the predicate, and may do decomposition;
+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose
+    canEqNC ev eq_rel ty1 ty2
+
+  | otherwise
+  = canIrred ev
 
 canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
                        , cc_tyargs = xis, cc_pend_sc = pend_sc })
@@ -101,21 +133,9 @@ canonicalize (CFunEqCan { cc_ev = ev
   = {-# SCC "canEqLeafFunEq" #-}
     canCFunEqCan ev fn xis1 fsk
 
-canonicalize (CIrredEvCan { cc_ev = ev })
-  = canIrred ev
 canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })
   = canHole ev hole
 
-canEvNC :: CtEvidence -> TcS (StopOrContinue Ct)
--- Called only for non-canonical EvVars
-canEvNC ev
-  = case classifyPredType (ctEvPred ev) of
-      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
-                                  canClassNC ev cls tys
-      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
-                                  canEqNC    ev eq_rel ty1 ty2
-      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr (ctEvPred ev))
-                                  canIrred   ev
 {-
 ************************************************************************
 *                                                                      *
@@ -130,13 +150,51 @@ canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
 -- Precondition: EvVar is class evidence
 canClassNC ev cls tys
   | isGiven ev  -- See Note [Eagerly expand given superclasses]
-  = do { sc_cts <- mkStrictSuperClasses ev cls tys
+  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
        ; emitWork sc_cts
        ; canClass ev cls tys False }
+
+  | isWanted ev
+  , Just ip_name <- isCallStackPred cls tys
+  , OccurrenceOf func <- ctLocOrigin loc
+  -- If we're given a CallStack constraint that arose from a function
+  -- call, we need to push the current call-site onto the stack instead
+  -- of solving it directly from a given.
+  -- See Note [Overview of implicit CallStacks] in TcEvidence
+  -- and Note [Solving CallStack constraints] in TcSMonad
+  = do { -- First we emit a new constraint that will capture the
+         -- given CallStack.
+       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
+                            -- We change the origin to IPOccOrigin so
+                            -- this rule does not fire again.
+                            -- See Note [Overview of implicit CallStacks]
+
+       ; new_ev <- newWantedEvVarNC new_loc pred
+
+         -- Then we solve the wanted by pushing the call-site
+         -- onto the newly emitted CallStack
+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
+       ; solveCallStack ev ev_cs
+
+       ; canClass new_ev cls tys False }
+
   | otherwise
   = canClass ev cls tys (has_scs cls)
+
   where
     has_scs cls = not (null (classSCTheta cls))
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
+-- Also called from TcSimplify when defaulting call stacks
+solveCallStack ev ev_cs = do
+  -- We're given ev_cs :: CallStack, but the evidence term should be a
+  -- dictionary, so we have to coerce ev_cs to a dictionary for
+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
+  cs_tm <- evCallStack ev_cs
+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
+  setEvBindIfWanted ev ev_tm
 
 canClass :: CtEvidence
          -> Class -> [Type]
@@ -147,8 +205,9 @@ canClass :: CtEvidence
 canClass ev cls tys pend_sc
   =   -- all classes do *nominal* matching
     ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
-    do { (xis, cos) <- flattenManyNom ev tys
-       ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
+    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
+       ; MASSERT( isTcReflCo _kind_co )
+       ; let co = mkTcTyConAppCo Nominal cls_tc cos
              xi = mkClassPred cls xis
              mk_ct new_ev = CDictCan { cc_ev = new_ev
                                      , cc_tyargs = xis
@@ -158,12 +217,14 @@ canClass ev cls tys pend_sc
        ; traceTcS "canClass" (vcat [ ppr ev
                                    , ppr xi, ppr mb ])
        ; return (fmap mk_ct mb) }
+  where
+    cls_tc = classTyCon cls
 
 {- Note [The superclass story]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to add superclass constraints for two reasons:
 
-* For givens [G], they give us a route to to proof.  E.g.
+* For givens [G], they give us a route to proof.  E.g.
     f :: Ord a => a -> Bool
     f x = x == x
   We get a Wanted (Eq a), which can only be solved from the superclass
@@ -203,19 +264,19 @@ So here's the plan:
 
 1. Eagerly generate superclasses for given (but not wanted)
    constraints; see Note [Eagerly expand given superclasses].
-   This is done in canClassNC, when we take a non-canonical constraint
-   and cannonicalise it.
+   This is done using mkStrictSuperClasses in canClassNC, when
+   we take a non-canonical Given constraint and cannonicalise it.
 
    However stop if you encounter the same class twice.  That is,
-   expand eagerly, but have a conservative termination condition: see
-   Note [Expanding superclasses] in TcType.
+   mkStrictSuperClasses expands eagerly, but has a conservative
+   termination condition: see Note [Expanding superclasses] in TcType.
 
 2. Solve the wanteds as usual, but do no further expansion of
    superclasses for canonical CDictCans in solveSimpleGivens or
    solveSimpleWanteds; Note [Danger of adding superclasses during solving]
 
-   However, /do/ continue to eagerly expand superlasses for /given/
-   non-canonical constraints (canClassNC does this).  As Trac #12175
+   However, /do/ continue to eagerly expand superlasses for new /given/
+   /non-canonical/ constraints (canClassNC does this).  As Trac #12175
    showed, a type-family application can expand to a class constraint,
    and we want to see its superclasses for just the same reason as
    Note [Eagerly expand given superclasses].
@@ -223,9 +284,20 @@ So here's the plan:
 3. If we have any remaining unsolved wanteds
         (see Note [When superclasses help] in TcRnTypes)
    try harder: take both the Givens and Wanteds, and expand
-   superclasses again.  This may succeed in generating (a finite
-   number of) extra Givens, and extra Deriveds. Both may help the
-   proof.  This is done in TcSimplify.expandSuperClasses.
+   superclasses again.  See the calls to expandSuperClasses in
+   TcSimplify.simpl_loop and solveWanteds.
+
+   This may succeed in generating (a finite number of) extra Givens,
+   and extra Deriveds. Both may help the proof.
+
+3a An important wrinkle: only expand Givens from the current level.
+   Two reasons:
+      - We only want to expand it once, and that is best done at
+        the level it is bound, rather than repeatedly at the leaves
+        of the implication tree
+      - We may be inside a type where we can't create term-level
+        evidence anyway, so we can't superclass-expand, say,
+        (a ~ b) to get (a ~# b).  This happened in Trac #15290.
 
 4. Go round to (2) again.  This loop (2,3,4) is implemented
    in TcSimplify.simpl_loop.
@@ -247,10 +319,31 @@ Why do we do this?  Two reasons:
 When we take a CNonCanonical or CIrredCan, but end up classifying it
 as a CDictCan, we set the cc_pend_sc flag to False.
 
+Note [Superclass loops]
+~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class C a => D a
+  class D a => C a
+
+Then, when we expand superclasses, we'll get back to the self-same
+predicate, so we have reached a fixpoint in expansion and there is no
+point in fruitlessly expanding further.  This case just falls out from
+our strategy.  Consider
+  f :: C a => a -> Bool
+  f x = x==x
+Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses
+G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)
+When processing d3 we find a match with d1 in the inert set, and we always
+keep the inert item (d1) if possible: see Note [Replacement vs keeping] in
+TcInteract.  So d3 dies a quick, happy death.
+
 Note [Eagerly expand given superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In step (1) of Note [The superclass story], why do we eagerly expand
-Given superclasses by one layer?  Mainly because of some very obscure
+Given superclasses by one layer?  (By "one layer" we mean expand transitively
+until you meet the same class again -- the conservative criterion embodied
+in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)
+We do this eagerly for Givens mainly because of some very obscure
 cases like this:
 
    instance Bad a => Eq (T a)
@@ -295,7 +388,7 @@ Examples of how adding superclasses can help:
     Follow the superclass rules to add
          [G] F a ~ b
          [D] F a ~ beta
-    Now we we get [D] beta ~ b, and can solve that.
+    Now we get [D] beta ~ b, and can solve that.
 
     -- Example (tcfail138)
       class L a b | a -> b
@@ -360,67 +453,67 @@ makeSuperClasses :: [Ct] -> TcS [Ct]
 makeSuperClasses cts = concatMapM go cts
   where
     go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
-          = mkStrictSuperClasses ev cls tys
+      = mkStrictSuperClasses ev [] [] cls tys
+    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have
+                                               -- class pred heads
+        mkStrictSuperClasses ev tvs theta cls tys
+      where
+        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
     go ct = pprPanic "makeSuperClasses" (ppr ct)
 
-mkStrictSuperClasses :: CtEvidence -> Class -> [Type] -> TcS [Ct]
--- Return constraints for the strict superclasses of (c tys)
-mkStrictSuperClasses ev cls tys
-  = mk_strict_superclasses (unitNameSet (className cls)) ev cls tys
-
-mk_superclasses :: NameSet -> CtEvidence -> TcS [Ct]
--- Return this constraint, plus its superclasses, if any
-mk_superclasses rec_clss ev
-  | ClassPred cls tys <- classifyPredType (ctEvPred ev)
-  = mk_superclasses_of rec_clss ev cls tys
-
-  | otherwise   -- Superclass is not a class predicate
-  = return [mkNonCanonical ev]
-
-mk_superclasses_of :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
--- Always return this class constraint,
--- and expand its superclasses
-mk_superclasses_of rec_clss ev cls tys
-  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
-                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True
-  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
-                                                          , ppr (isCTupleClass cls)
-                                                          , ppr rec_clss
-                                                          ])
-                    ; sc_cts <- mk_strict_superclasses rec_clss' ev cls tys
-                    ; return (this_ct : sc_cts) }
-                                   -- cc_pend_sc of this_ct = False
-  where
-    cls_nm     = className cls
-    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
-                 -- Tuples never contribute to recursion, and can be nested
-    rec_clss'  = rec_clss `extendNameSet` cls_nm
-    this_ct    = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
-                          , cc_pend_sc = loop_found }
-                 -- NB: If there is a loop, we cut off, so we have not
-                 --     added the superclasses, hence cc_pend_sc = True
-
-mk_strict_superclasses :: NameSet -> CtEvidence -> Class -> [Type] -> TcS [Ct]
+mkStrictSuperClasses
+    :: CtEvidence
+    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking
+                             -- superclasses of a /quantified/ constraint
+    -> Class -> [Type] -> TcS [Ct]
+-- Return constraints for the strict superclasses of
+--   ev :: forall as. theta => cls tys
+mkStrictSuperClasses ev tvs theta cls tys
+  = mk_strict_superclasses (unitNameSet (className cls))
+                           ev tvs theta cls tys
+
+mk_strict_superclasses :: NameSet -> CtEvidence
+                       -> [TyVar] -> ThetaType
+                       -> Class -> [Type] -> TcS [Ct]
 -- Always return the immediate superclasses of (cls tys);
 -- and expand their superclasses, provided none of them are in rec_clss
 -- nor are repeated
-mk_strict_superclasses rec_clss ev cls tys
+mk_strict_superclasses rec_clss ev tvs theta cls tys
   | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
-  = do { sc_evs <- newGivenEvVars (mk_given_loc loc)
-                                  (mkEvScSelectors (EvId evar) cls tys)
-       ; concatMapM (mk_superclasses rec_clss) sc_evs }
+  = concatMapM (do_one_given evar (mk_given_loc loc)) $
+    classSCSelIds cls
+  where
+    dict_ids  = mkTemplateLocals theta
+    size      = sizeTypes tys
+
+    do_one_given evar given_loc sel_id
+      | not (null tvs)
+      , null theta
+      , isUnliftedType sc_pred
+      -- Very special case for equality
+      -- See Note [Equality superclasses in quantified constraints]
+      = do { empty_ctuple_cls <- tcLookupClass (cTupleTyConName 0)
+           ; let theta1    = [mkClassPred empty_ctuple_cls []]
+                 dict_ids1 = mkTemplateLocals theta1
+           ; given_ev <- new_given theta1 dict_ids1 []
+           ; return [mkNonCanonical given_ev] }
+
+      | otherwise  -- Normal case
+      = do { given_ev <- new_given theta dict_ids dict_ids
+           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
 
-  | all noFreeVarsOfType tys
-  = return [] -- Wanteds with no variables yield no deriveds.
-              -- See Note [Improvement from Ground Wanteds]
+      where
+        sc_pred = funResultTy (piResultTys (idType sel_id) tys)
+
+        new_given theta_abs dict_ids_abs dict_ids_app
+          = newGivenEvVar given_loc (given_ty, given_ev)
+          where
+            given_ty = mkInfSigmaTy tvs theta_abs sc_pred
+            given_ev = EvExpr $ mkLams tvs $ mkLams dict_ids_abs $
+                       Var sel_id `mkTyApps` tys `App`
+                       (evId evar `mkTyApps` mkTyVarTys tvs `mkVarApps` dict_ids_app)
 
-  | otherwise -- Wanted/Derived case, just add Derived superclasses
-              -- that can lead to improvement.
-  = do { let loc = ctEvLoc ev
-       ; sc_evs <- mapM (newDerivedNC loc) (immSuperClasses cls tys)
-       ; concatMapM (mk_superclasses rec_clss) sc_evs }
-  where
-    size = sizeTypes tys
     mk_given_loc loc
        | isCTupleClass cls
        = loc   -- For tuple predicates, just take them apart, without
@@ -439,8 +532,103 @@ mk_strict_superclasses rec_clss ev cls tys
        | otherwise  -- Probably doesn't happen, since this function
        = loc        -- is only used for Givens, but does no harm
 
+mk_strict_superclasses rec_clss ev tvs theta cls tys
+  | all noFreeVarsOfType tys
+  = return [] -- Wanteds with no variables yield no deriveds.
+              -- See Note [Improvement from Ground Wanteds]
+
+  | otherwise -- Wanted/Derived case, just add Derived superclasses
+              -- that can lead to improvement.
+  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )
+    concatMapM do_one_derived (immSuperClasses cls tys)
+  where
+    loc = ctEvLoc ev
+
+    do_one_derived sc_pred
+      = do { sc_ev <- newDerivedNC loc sc_pred
+           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+
+mk_superclasses :: NameSet -> CtEvidence
+                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
+-- Return this constraint, plus its superclasses, if any
+mk_superclasses rec_clss ev tvs theta pred
+  | ClassPred cls tys <- classifyPredType pred
+  = mk_superclasses_of rec_clss ev tvs theta cls tys
+
+  | otherwise   -- Superclass is not a class predicate
+  = return [mkNonCanonical ev]
+
+mk_superclasses_of :: NameSet -> CtEvidence
+                   -> [TyVar] -> ThetaType -> Class -> [Type]
+                   -> TcS [Ct]
+-- Always return this class constraint,
+-- and expand its superclasses
+mk_superclasses_of rec_clss ev tvs theta cls tys
+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True
+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
+                                                          , ppr (isCTupleClass cls)
+                                                          , ppr rec_clss
+                                                          ])
+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+                    ; return (this_ct : sc_cts) }
+                                   -- cc_pend_sc of this_ct = False
+  where
+    cls_nm     = className cls
+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
+                 -- Tuples never contribute to recursion, and can be nested
+    rec_clss'  = rec_clss `extendNameSet` cls_nm
+
+    this_ct | null tvs, null theta
+            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
+                       , cc_pend_sc = loop_found }
+                 -- NB: If there is a loop, we cut off, so we have not
+                 --     added the superclasses, hence cc_pend_sc = True
+            | otherwise
+            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
+                             , qci_ev = ev
+                             , qci_pend_sc = loop_found })
+
+
+{- Note [Equality superclasses in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #15359, #15593, #15625)
+  f :: (forall a. theta => a ~ b) => stuff
+
+It's a bit odd to have a local, quantified constraint for `(a~b)`,
+but some people want such a thing (see the tickets). And for
+Coercible it is definitely useful
+  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
+                 => stuff
+
+Moreover it's not hard to arrange; we just need to look up /equality/
+constraints in the quantified-constraint environment, which we do in
+TcInteract.doTopReactOther.
+
+There is a wrinkle though, in the case where 'theta' is empty, so
+we have
+  f :: (forall a. a~b) => stuff
+
+Now the superclass machinery kicks in, in makeSuperClasses,
+giving us a a second quantified constrait
+       (forall a. a ~# b)
+BUT this is an unboxed value!  And nothing has prepared us for
+dictionary "functions" that are unboxed.  Actually it does just
+about work, but the simplier ends up with stuff like
+   case (/\a. eq_sel d) of df -> ...(df @Int)...
+and fails to simplify that any further.
+
+It seems eaiser to give such unboxed quantifed constraints a
+dummmy () argument, thus
+      (forall a. (% %) => a ~# b)
+where (% %) is the empty constraint tuple.  That makes everything
+be nicely boxed.
+
+(One might wonder about using void# instead, but this seems more
+uniform -- it's a constraint argument -- and I'm not worried about
+the last drop of efficiency for this very rare case.)
+
 
-{-
 ************************************************************************
 *                                                                      *
 *                      Irreducibles canonicalization
@@ -450,28 +638,182 @@ mk_strict_superclasses rec_clss ev cls tys
 
 canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Precondition: ty not a tuple and no other evidence form
-canIrred old_ev
-  = do { let old_ty = ctEvPred old_ev
-       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)
-       ; (xi,co) <- flatten FM_FlattenAll old_ev old_ty -- co :: xi ~ old_ty
-       ; rewriteEvidence old_ev xi co `andWhenContinue` \ new_ev ->
+canIrred ev
+  = do { let pred = ctEvPred ev
+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
+       ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
     do { -- Re-classify, in case flattening has improved its shape
        ; case classifyPredType (ctEvPred new_ev) of
            ClassPred cls tys     -> canClassNC new_ev cls tys
            EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2
            _                     -> continueWith $
-                                    CIrredEvCan { cc_ev = new_ev } } }
+                                    mkIrredCt new_ev } }
 
 canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)
 canHole ev hole
-  = do { let ty = ctEvPred ev
-       ; (xi,co) <- flatten FM_SubstOnly ev ty -- co :: xi ~ ty
+  = do { let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
        ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
-    do { emitInsoluble (CHoleCan { cc_ev = new_ev
-                                 , cc_hole = hole })
+    do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev
+                                             , cc_hole = hole }))
        ; stopWith new_ev "Emit insoluble hole" } }
 
-{-
+
+{- *********************************************************************
+*                                                                      *
+*                      Quantified predicates
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The -XQuantifiedConstraints extension allows type-class contexts like this:
+
+  data Rose f x = Rose x (f (Rose f x))
+
+  instance (Eq a, forall b. Eq b => Eq (f b))
+        => Eq (Rose f a)  where
+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
+
+Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
+This quantified constraint is needed to solve the
+ [W] (Eq (f (Rose f x)))
+constraint which arises form the (==) definition.
+
+The wiki page is
+  https://ghc.haskell.org/trac/ghc/wiki/QuantifiedConstraints
+which in turn contains a link to the GHC Proposal where the change
+is specified, and a Haskell Symposium paper about it.
+
+We implement two main extensions to the design in the paper:
+
+ 1. We allow a variable in the instance head, e.g.
+      f :: forall m a. (forall b. m b) => D (m a)
+    Notice the 'm' in the head of the quantified constraint, not
+    a class.
+
+ 2. We suport superclasses to quantified constraints.
+    For example (contrived):
+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
+      f x y = x==y
+    Here we need (Eq (m a)); but the quantifed constraint deals only
+    with Ord.  But we can make it work by using its superclass.
+
+Here are the moving parts
+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}
+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
+
+  * A new form of evidence, EvDFun, that is used to discharge
+    such wanted constraints
+
+  * checkValidType gets some changes to accept forall-constraints
+    only in the right places.
+
+  * Type.PredTree gets a new constructor ForAllPred, and
+    and classifyPredType analyses a PredType to decompose
+    the new forall-constraints
+
+  * TcSMonad.InertCans gets an extra field, inert_insts,
+    which holds all the Given forall-constraints.  In effect,
+    such Given constraints are like local instance decls.
+
+  * When trying to solve a class constraint, via
+    TcInteract.matchInstEnv, use the InstEnv from inert_insts
+    so that we include the local Given forall-constraints
+    in the lookup.  (See TcSMonad.getInstEnvs.)
+
+  * TcCanonical.canForAll deals with solving a
+    forall-constraint.  See
+       Note [Solving a Wanted forall-constraint]
+
+  * We augment the kick-out code to kick out an inert
+    forall constraint if it can be rewritten by a new
+    type equality; see TcSMonad.kick_out_rewritable
+
+Note that a quantified constraint is never /inferred/
+(by TcSimplify.simplifyInfer).  A function can only have a
+quantified constraint in its type if it is given an explicit
+type signature.
+
+Note that we implement
+-}
+
+canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+-- We have a constraint (forall as. blah => C tys)
+canForAll ev pend_sc
+  = do { -- First rewrite it to apply the current substitution
+         -- Do not bother with type-family reductions; we can't
+         -- do them under a forall anyway (c.f. Flatten.flatten_one
+         -- on a forall type)
+         let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+
+    do { -- Now decompose into its pieces and solve it
+         -- (It takes a lot less code to flatten before decomposing.)
+       ; case classifyPredType (ctEvPred new_ev) of
+           ForAllPred tv_bndrs theta pred
+              -> solveForAll new_ev tv_bndrs theta pred pend_sc
+           _  -> pprPanic "canForAll" (ppr new_ev)
+    } }
+
+solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool
+            -> TcS (StopOrContinue Ct)
+solveForAll ev tv_bndrs theta pred pend_sc
+  | CtWanted { ctev_dest = dest } <- ev
+  = -- See Note [Solving a Wanted forall-constraint]
+    do { let skol_info = QuantCtxtSkol
+             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
+                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs
+       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)
+
+       ; (w_id, ev_binds)
+             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $
+                do { wanted_ev <- newWantedEvVarNC loc $
+                                  substTy subst pred
+                   ; return ( ctEvEvId wanted_ev
+                            , unitBag (mkNonCanonical wanted_ev)) }
+
+      ; setWantedEvTerm dest $
+        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
+              , et_binds = ev_binds, et_body = w_id }
+
+      ; stopWith ev "Wanted forall-constraint" }
+
+  | isGiven ev   -- See Note [Solving a Given forall-constraint]
+  = do { addInertForAll qci
+       ; stopWith ev "Given forall-constraint" }
+
+  | otherwise
+  = stopWith ev "Derived forall-constraint"
+  where
+    loc = ctEvLoc ev
+    tvs = binderVars tv_bndrs
+    qci = QCI { qci_ev = ev, qci_tvs = tvs
+              , qci_pred = pred, qci_pend_sc = pend_sc }
+
+{- Note [Solving a Wanted forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a wanted forall (quantified) constraint
+  [W] df :: forall ab. (Eq a, Ord b) => C x a b
+is delightfully easy.   Just build an implication constraint
+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
+and discharge df thus:
+    df = /\ab. \g1 g2. let <binds> in d
+where <binds> is filled in by solving the implication constraint.
+All the machinery is to hand; there is little to do.
+
+Note [Solving a Given forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a Given constraint
+  [G] df :: forall ab. (Eq a, Ord b) => C x a b
+we just add it to TcS's local InstEnv of known instances,
+via addInertForall.  Then, if we look up (C x Int Bool), say,
+we'll find a match in the InstEnv.
+
+
 ************************************************************************
 *                                                                      *
 *        Equalities
@@ -556,11 +898,14 @@ can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
   = canEqReflexive ev ReprEq ty1
 
 -- When working with ReprEq, unwrap newtypes.
-can_eq_nc' _flat rdr_env envs ev ReprEq ty1 _ ty2 ps_ty2
-  | Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
+-- See Note [Unwrap newtypes first]
+can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | ReprEq <- eq_rel
+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
   = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
-can_eq_nc' _flat rdr_env envs ev ReprEq ty1 ps_ty1 ty2 _
-  | Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
+
+  | ReprEq <- eq_rel
+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
   = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1
 
 -- Then, get rid of casts
@@ -569,6 +914,13 @@ can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
 can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
   = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
 
+-- NB: pattern match on True: we want only flat types sent to canEqTyVar.
+-- See also Note [No top-level newtypes on RHS of representational equalities]
+can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
+  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
+  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
+
 ----------------------
 -- Otherwise try to decompose
 ----------------------
@@ -576,7 +928,7 @@ can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
 -- Literals
 can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
  | l1 == l2
-  = do { setEqIfWanted ev (mkReflCo (eqRelRole eq_rel) ty1)
+  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
        ; stopWith ev "Equal LitTy" }
 
 -- Try to decompose type constructor applications
@@ -595,32 +947,38 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel
 
 -- See Note [Canonicalising type applications] about why we require flat types
 can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
-  | Just (t2, s2) <- tcSplitAppTy_maybe ty2
-  = can_eq_app ev eq_rel t1 s1 t2 s2
+  | NomEq <- eq_rel
+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
+  = can_eq_app ev t1 s1 t2 s2
 can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
-  | Just (t1, s1) <- tcSplitAppTy_maybe ty1
-  = can_eq_app ev eq_rel t1 s1 t2 s2
+  | NomEq <- eq_rel
+  , Just (t1, s1) <- tcSplitAppTy_maybe ty1
+  = can_eq_app ev t1 s1 t2 s2
 
 -- No similarity in type structure detected. Flatten and try again.
 can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
   = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
        ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
-       ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
-         `andWhenContinue` \ new_ev ->
-         can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
-
--- Type variable on LHS or RHS are last.
--- NB: pattern match on True: we want only flat types sent to canEqTyVar.
--- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
-  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
-  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
 
 -- We've flattened and the types don't match. Give up.
-can_eq_nc' True _rdr_env _envs ev _eq_rel _ ps_ty1 _ ps_ty2
+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
   = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
-       ; canEqHardFailure ev ps_ty1 ps_ty2 }
+       ; case eq_rel of -- See Note [Unsolved equalities]
+            ReprEq -> continueWith (mkIrredCt ev)
+            NomEq  -> continueWith (mkInsolubleCt ev) }
+          -- No need to call canEqFailure/canEqHardFailure because they
+          -- flatten, and the types involved here are already flat
+
+{- Note [Unsolved equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved equality like
+  (a b ~R# Int)
+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
+So we want to make it a potentially-soluble Irred not an insoluble one.
+Missing this point is what caused Trac #15431
+-}
 
 ---------------------------------
 can_eq_nc_forall :: CtEvidence -> EqRel
@@ -636,10 +994,9 @@ can_eq_nc_forall :: CtEvidence -> EqRel
 
 can_eq_nc_forall ev eq_rel s1 s2
  | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev
- = do { let free_tvs1 = tyCoVarsOfType s1
-            free_tvs2 = tyCoVarsOfType s2
-            (bndrs1, phi1) = tcSplitForAllTyVarBndrs s1
-            (bndrs2, phi2) = tcSplitForAllTyVarBndrs s2
+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
+            (bndrs1, phi1) = tcSplitForAllVarBndrs s1
+            (bndrs2, phi2) = tcSplitForAllVarBndrs s2
       ; if not (equalLength bndrs1 bndrs2)
         then do { traceTcS "Forall failure" $
                      vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
@@ -648,7 +1005,7 @@ can_eq_nc_forall ev eq_rel s1 s2
                 ; canEqHardFailure ev s1 s2 }
         else
    do { traceTcS "Creating implication for polytype equality" $ ppr ev
-      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs1
+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs
       ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $
                               binderVars bndrs1
 
@@ -656,35 +1013,30 @@ can_eq_nc_forall ev eq_rel s1 s2
             phi1' = substTy subst1 phi1
 
             -- Unify the kinds, extend the substitution
+            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]
+               -> TcS (TcCoercion, Cts)
             go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
               = do { let tv2 = binderVar bndr2
-                   ; kind_co <- unifyWanted loc Nominal
-                                            (tyVarKind skol_tv)
-                                            (substTy subst (tyVarKind tv2))
+                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)
+                                                  (substTy subst (tyVarKind tv2))
                    ; let subst' = extendTvSubst subst tv2
                                        (mkCastTy (mkTyVarTy skol_tv) kind_co)
-                   ; co <- go skol_tvs subst' bndrs2
-                   ; return (mkForAllCo skol_tv kind_co co) }
+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
+                   ; return ( mkTcForAllCo skol_tv kind_co co
+                            , wanteds1 `unionBags` wanteds2 ) }
 
             -- Done: unify phi1 ~ phi2
             go [] subst bndrs2
               = ASSERT( null bndrs2 )
-                unifyWanted loc (eqRelRole eq_rel)
-                            phi1' (substTy subst phi2)
+                unify loc (eqRelRole eq_rel) phi1' (substTy subst phi2)
 
             go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
 
-            empty_subst2 = mkEmptyTCvSubst $ mkInScopeSet $
-                           free_tvs2 `extendVarSetList` skol_tvs
+            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
 
-      ; (implic, _ev_binds, all_co) <- buildImplication skol_info skol_tvs [] $
-                                       go skol_tvs empty_subst2 bndrs2
-           -- We have nowhere to put these bindings
-           -- but TcSimplify.setImplicationStatus
-           -- checks that we don't actually use them
-           -- when skol_info = UnifyForAllSkol
+      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $
+                  go skol_tvs empty_subst2 bndrs2
 
-      ; updWorkListTcS (extendWorkListImplic implic)
       ; setWantedEq orig_dest all_co
       ; stopWith ev "Deferred polytype equality" } }
 
@@ -693,6 +1045,17 @@ can_eq_nc_forall ev eq_rel s1 s2
         pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]
       ; stopWith ev "Discard given polytype equality" }
 
+ where
+    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
+    -- This version returns the wanted constraint rather
+    -- than putting it in the work list
+    unify loc role ty1 ty2
+      | ty1 `tcEqType` ty2
+      = return (mkTcReflCo role ty1, emptyBag)
+      | otherwise
+      = do { (wanted, co) <- newWantedEq loc role ty1 ty2
+           ; return (co, unitBag (mkNonCanonical wanted)) }
+
 ---------------------------------
 -- | Compare types for equality, while zonking as necessary. Gives up
 -- as soon as it finds that two types are not equal.
@@ -777,7 +1140,8 @@ zonk_eq_types = go
             -> do { cts <- readTcRef ref
                   ; case cts of
                       Flexi        -> give_up
-                      Indirect ty' -> unSwap swapped go ty' ty }
+                      Indirect ty' -> do { trace_indirect tv ty'
+                                         ; unSwap swapped go ty' ty } }
           _ -> give_up
       where
         give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
@@ -790,12 +1154,17 @@ zonk_eq_types = go
                           then go ty1' ty2'
                           else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
 
+    trace_indirect tv ty
+       = traceTcS "Following filled tyvar (zonk_eq_types)"
+                  (ppr tv <+> equals <+> ppr ty)
+
     quick_zonk tv = case tcTyVarDetails tv of
       MetaTv { mtv_ref = ref }
         -> do { cts <- readTcRef ref
               ; case cts of
                   Flexi        -> return (TyVarTy tv, False)
-                  Indirect ty' -> return (ty', True) }
+                  Indirect ty' -> do { trace_indirect tv ty'
+                                     ; return (ty', True) } }
       _ -> return (TyVarTy tv, False)
 
       -- This happens for type families, too. But recall that failure
@@ -824,7 +1193,26 @@ zonk_eq_types = go
     combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
     combine_rev f (Right tys) (Right ty) = Right (f ty tys)
 
-{-
+{- See Note [Unwrap newtypes first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  newtype N m a = MkN (m a)
+Then N will get a conservative, Nominal role for its second paramter 'a',
+because it appears as an argument to the unknown 'm'. Now consider
+  [W] N Maybe a  ~R#  N Maybe b
+
+If we decompose, we'll get
+  [W] a ~N# b
+
+But if instead we unwrap we'll get
+  [W] Maybe a ~R# Maybe b
+which in turn gives us
+  [W] a ~R# b
+which is easier to satisfy.
+
+Bottom line: unwrap newtypes before decomposing them!
+c.f. Trac #9123 comment:52,53 for a compelling example.
+
 Note [Newtypes can blow the stack]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have
@@ -865,7 +1253,7 @@ Here's another place where this reflexivity check is key:
 Consider trying to prove (f a) ~R (f a). The AppTys in there can't
 be decomposed, because representational equality isn't congruent with respect
 to AppTy. So, when canonicalising the equality above, we get stuck and
-would normally produce a CIrredEvCan. However, we really do want to
+would normally produce a CIrredCan. However, we really do want to
 be able to solve (f a) ~R (f a). So, in the representational case only,
 we do a reflexivity check.
 
@@ -893,16 +1281,15 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
            -- we have actually used the newtype constructor here, so
            -- make sure we don't warn about importing it!
 
-       ; rewriteEqEvidence ev swapped ty1' ps_ty2
-                           (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
-         `andWhenContinue` \ new_ev ->
-         can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
+       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2
+                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
 
 ---------
 -- ^ Decompose a type application.
 -- All input types must be flat. See Note [Canonicalising type applications]
-can_eq_app :: CtEvidence       -- :: s1 t1 ~r s2 t2
-           -> EqRel            -- r
+-- Nominal equality only!
+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
            -> Xi -> Xi         -- s1 t1
            -> Xi -> Xi         -- s2 t2
            -> TcS (StopOrContinue Ct)
@@ -910,34 +1297,46 @@ can_eq_app :: CtEvidence       -- :: s1 t1 ~r s2 t2
 -- AppTys only decompose for nominal equality, so this case just leads
 -- to an irreducible constraint; see typecheck/should_compile/T10494
 -- See Note [Decomposing equality], note {4}
-can_eq_app ev ReprEq _ _ _ _
-  = do { traceTcS "failing to decompose representational AppTy equality" (ppr ev)
-       ; continueWith (CIrredEvCan { cc_ev = ev }) }
-          -- no need to call canEqFailure, because that flattens, and the
-          -- types involved here are already flat
-
-can_eq_app ev NomEq s1 t1 s2 t2
+can_eq_app ev s1 t1 s2 t2
   | CtDerived { ctev_loc = loc } <- ev
   = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
        ; stopWith ev "Decomposed [D] AppTy" }
   | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev
   = do { co_s <- unifyWanted loc Nominal s1 s2
-       ; co_t <- unifyWanted loc Nominal t1 t2
+       ; let arg_loc
+               | isNextArgVisible s1 = loc
+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
+       ; co_t <- unifyWanted arg_loc Nominal t1 t2
        ; let co = mkAppCo co_s co_t
        ; setWantedEq dest co
        ; stopWith ev "Decomposed [W] AppTy" }
+
+    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
+    -- below is ill-typed, potentially leading to a panic in splitTyConApp
+    -- Test case: typecheck/should_run/Typeable1
+    -- We could also include this mismatch check above (for W and D), but it's slow
+    -- and we'll get a better error message not doing it
+  | s1k `mismatches` s2k
+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
+
   | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
   = do { let co   = mkTcCoVarCo evar
              co_s = mkTcLRCo CLeft  co
              co_t = mkTcLRCo CRight co
        ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
-                                     , EvCoercion co_s )
+                                     , evCoercion co_s )
        ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
-                                     , EvCoercion co_t )
+                                     , evCoercion co_t )
        ; emitWorkNC [evar_t]
        ; canEqNC evar_s NomEq s1 s2 }
-  | otherwise  -- Can't happen
-  = error "can_eq_app"
+
+  where
+    s1k = typeKind s1
+    s2k = typeKind s2
+
+    k1 `mismatches` k2
+      =  isForAllTy k1 && not (isForAllTy k2)
+      || not (isForAllTy k1) && isForAllTy k2
 
 -----------------------
 -- | Break apart an equality over a casted type
@@ -953,12 +1352,10 @@ canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2
   = do { traceTcS "Decomposing cast" (vcat [ ppr ev
                                            , ppr ty1 <+> text "|>" <+> ppr co1
                                            , ppr ps_ty2 ])
-       ; rewriteEqEvidence ev swapped ty1 ps_ty2
-                           (mkTcReflCo role ty1
-                              `mkTcCoherenceRightCo` co1)
-                           (mkTcReflCo role ps_ty2)
-         `andWhenContinue` \ new_ev ->
-         can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
+       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2
+                                     (mkTcGReflRightCo role ty1 co1)
+                                     (mkTcReflCo role ps_ty2)
+       ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
   where
     role = eqRelRole eq_rel
 
@@ -982,7 +1379,7 @@ canTyConApp ev eq_rel tc1 tys1 tc2 tys2
   -- See Note [Skolem abstract data] (at tyConSkolem)
   | tyConSkolem tc1 || tyConSkolem tc2
   = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
-       ; continueWith (CIrredEvCan { cc_ev = ev }) }
+       ; continueWith (mkIrredCt ev) }
 
   -- Fail straight away for better error messages
   -- See Note [Use canEqFailure in canDecomposableTyConApp]
@@ -1203,7 +1600,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
         -> do { let ev_co = mkCoVarCo evar
               ; given_evs <- newGivenEvVars loc $
                              [ ( mkPrimEqPredRole r ty1 ty2
-                               , EvCoercion (mkNthCo i ev_co) )
+                               , evCoercion $ mkNthCo r i ev_co )
                              | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
                              , r /= Phantom
                              , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
@@ -1216,13 +1613,16 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
       -- the following makes a better distinction between "kind" and "type"
       -- in error messages
     bndrs      = tyConBinders tc
-    kind_loc   = toKindLoc loc
     is_kinds   = map isNamedTyConBinder bndrs
-    new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc
-             = repeat loc
-             | otherwise
-             = map (\is_kind -> if is_kind then kind_loc else loc) is_kinds
+    is_viss    = map isVisibleTyConBinder bndrs
+
+    kind_xforms = map (\is_kind -> if is_kind then toKindLoc else id) is_kinds
+    vis_xforms  = map (\is_vis  -> if is_vis  then id
+                                   else flip updateCtLocOrigin toInvisibleOrigin)
+                      is_viss
 
+    -- zipWith3 (.) composes its first two arguments and applies it to the third
+    new_locs = zipWith3 (.) kind_xforms vis_xforms (repeat loc)
 
 -- | Call when canonicalizing an equality fails, but if the equality is
 -- representational, there is some hope for the future.
@@ -1239,9 +1639,8 @@ canEqFailure ev ReprEq ty1 ty2
             -- new equalities become available
        ; traceTcS "canEqFailure with ReprEq" $
          vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]
-       ; rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
-         `andWhenContinue` \ new_ev ->
-         continueWith (CIrredEvCan { cc_ev = new_ev }) }
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; continueWith (mkIrredCt new_ev) }
 
 -- | Call when canonicalizing an equality fails with utterly no hope.
 canEqHardFailure :: CtEvidence
@@ -1250,10 +1649,8 @@ canEqHardFailure :: CtEvidence
 canEqHardFailure ev ty1 ty2
   = do { (s1, co1) <- flatten FM_SubstOnly ev ty1
        ; (s2, co2) <- flatten FM_SubstOnly ev ty2
-       ; rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
-         `andWhenContinue` \ new_ev ->
-    do { emitInsoluble (mkNonCanonical new_ev)
-       ; stopWith new_ev "Definitely not equal" }}
+       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
+       ; continueWith (mkInsolubleCt new_ev) }
 
 {-
 Note [Decomposing TyConApps]
@@ -1356,19 +1753,25 @@ isInsolubleOccursCheck does.
 
 See also #10715, which induced this addition.
 
-Note [No derived kind equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we're working with a heterogeneous derived equality
-
-  [D] (t1 :: k1) ~ (t2 :: k2)
-
-we want to homogenise to establish the kind invariant on CTyEqCans.
-But we can't emit [D] k1 ~ k2 because we wouldn't then be able to
-use the evidence in the homogenised types. So we emit a wanted
-constraint, because we do really need the evidence here.
-
-Thus: no derived kind equalities.
-
+Note [canCFunEqCan]
+~~~~~~~~~~~~~~~~~~~
+Flattening the arguments to a type family can change the kind of the type
+family application. As an easy example, consider (Any k) where (k ~ Type)
+is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
+The problem here is that the fsk in the CFunEqCan will have the old kind.
+
+The solution is to come up with a new fsk/fmv of the right kind. For
+givens, this is easy: just introduce a new fsk and update the flat-cache
+with the new one. For wanteds, we want to solve the old one if favor of
+the new one, so we use dischargeFmv. This also kicks out constraints
+from the inert set; this behavior is correct, as the kind-change may
+allow more constraints to be solved.
+
+We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case
+if we really need to.  Of course `flattenArgsNom` should return `Refl`
+whenever possible, but Trac #15577 was an infinite loop because even
+though the coercion was homo-kinded, `kind_co` was not `Refl`, so we
+made a new (identical) CFunEqCan, and then the entire process repeated.
 -}
 
 canCFunEqCan :: CtEvidence
@@ -1380,90 +1783,254 @@ canCFunEqCan :: CtEvidence
 -- and the RHS is a fsk, which we must *not* substitute.
 -- So just substitute in the LHS
 canCFunEqCan ev fn tys fsk
-  = do { (tys', cos) <- flattenManyNom ev tys
+  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
                         -- cos :: tys' ~ tys
        ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
                         -- :: F tys' ~ F tys
              new_lhs = mkTyConApp fn tys'
-             fsk_ty  = mkTyVarTy fsk
-       ; rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
-                           lhs_co (mkTcNomReflCo fsk_ty)
-         `andWhenContinue` \ ev' ->
-    do { extendFlatCache fn tys' (ctEvCoercion ev', fsk_ty, ctEvFlavour ev')
+
+             flav    = ctEvFlavour ev
+       ; (ev', fsk')
+           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]
+              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs $$ ppr lhs_co)
+                      ; let fsk_ty = mkTyVarTy fsk
+                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
+                                                 lhs_co (mkTcNomReflCo fsk_ty)
+                      ; return (ev', fsk) }
+              else do { traceTcS "canCFunEqCan: non-refl" $
+                        vcat [ text "Kind co:" <+> ppr kind_co
+                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)
+                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))
+                                                  2 (dcolon <+> ppr (typeKind (mkTyConApp fn tys)))
+                             , text "New LHS" <+> hang (ppr new_lhs)
+                                                     2 (dcolon <+> ppr (typeKind new_lhs)) ]
+                      ; (ev', new_co, new_fsk)
+                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
+                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
+                               -- sym lhs_co :: F tys ~ F tys'
+                               -- new_co     :: F tys' ~ new_fsk
+                               -- co         :: F tys ~ (new_fsk |> kind_co)
+                            co = mkTcSymCo lhs_co `mkTcTransCo`
+                                 mkTcCoherenceRightCo Nominal
+                                                      (mkTyVarTy new_fsk)
+                                                      kind_co
+                                                      new_co
+
+                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
+                      ; dischargeFunEq ev fsk co xi
+                      ; return (ev', new_fsk) }
+
+       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
        ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
-                                 , cc_tyargs = tys', cc_fsk = fsk }) } }
+                                 , cc_tyargs = tys', cc_fsk = fsk' }) }
 
 ---------------------
 canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs
            -> EqRel -> SwapFlag
-           -> TcTyVar -> TcType   -- lhs: already flat, not a cast
-           -> TcType -> TcType    -- rhs: already flat, not a cast
+           -> TcTyVar               -- tv1
+           -> TcType                -- lhs: pretty lhs, already flat
+           -> TcType -> TcType      -- rhs: already flat
            -> TcS (StopOrContinue Ct)
-canEqTyVar ev eq_rel swapped tv1 ps_ty1 (TyVarTy tv2) _
-  | tv1 == tv2
-  = canEqReflexive ev eq_rel ps_ty1
+canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
+  | k1 `tcEqType` k2
+  = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
 
-  | swapOverTyVars tv1 tv2
-  = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
+         -- Note [Flattening] in TcFlatten gives us (F2), which says that
+         -- flattening is always homogeneous (doesn't change kinds). But
+         -- perhaps by flattening the kinds of the two sides of the equality
+         -- at hand makes them equal. So let's try that.
+  | otherwise
+  = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)
+       ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)
+       ; traceTcS "canEqTyVar tried flattening kinds"
+                  (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)
+                              , text "~"
+                              , parens (ppr xi2 <+> dcolon <+> ppr k2) ]
+                        , ppr flat_k1
+                        , ppr k1_co
+                        , ppr flat_k2
+                        , ppr k2_co ])
+
+         -- we know the LHS is a tyvar. So let's dump all the coercions on the RHS
+         -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and
+         -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
+         -- (as an optimization, so that we don't have to flatten the kinds again)
+         -- and then emit a kind equality in canEqTyVarHetero.
+         -- See Note [Equalities with incompatible kinds]
+
+       ; let role = eqRelRole eq_rel
+       ; if flat_k1 `tcEqType` flat_k2
+         then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co
+                         -- :: kind(xi2) ~N kind(xi1)
+
+                       new_rhs     = xi2 `mkCastTy` rhs_kind_co
+                       ps_rhs      = ps_xi2 `mkCastTy` rhs_kind_co
+                       rhs_co      = mkTcGReflLeftCo role xi2 rhs_kind_co
+
+                 ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs
+                                               (mkTcReflCo role xi1) rhs_co
+                       -- NB: rewriteEqEvidence executes a swap, if any, so we're
+                       -- NotSwapped now.
+                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }
+         else
+    do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1
+             sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2
+
+             new_lhs = xi1 `mkCastTy` sym_k1_co  -- :: flat_k1
+             new_rhs = xi2 `mkCastTy` sym_k2_co  -- :: flat_k2
+             ps_rhs  = ps_xi2 `mkCastTy` sym_k2_co
+
+             lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co
+             rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co
+               -- lhs_co :: (xi1 |> sym k1_co) ~ xi1
+               -- rhs_co :: (xi2 |> sym k2_co) ~ xi2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+         -- no longer swapped, due to rewriteEqEvidence
+       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1
+                                        new_rhs flat_k2 ps_rhs } }
+  where
+    xi1 = mkTyVarTy tv1
+
+    k1 = tyVarKind tv1
+    k2 = typeKind xi2
+
+    loc  = ctEvLoc ev
+    flav = ctEvFlavour ev
+
+canEqTyVarHetero :: CtEvidence   -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2)
+                 -> EqRel
+                 -> TcTyVar -> TcCoercionN -> TcKind  -- tv1 |> co1 :: ki1
+                 -> TcType            -- pretty tv1 (*without* the coercion)
+                 -> TcType -> TcKind  -- xi2 :: ki2
+                 -> TcType            -- pretty xi2
+                 -> TcS (StopOrContinue Ct)
+canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
+  -- See Note [Equalities with incompatible kinds]
+  | CtGiven { ctev_evar = evar } <- ev
+    -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)
+    -- swapped  : tm :: (rhs :: ki2) ~ (lhs :: ki1)
+  = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)
+       ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
+       ; let  -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)   (whether swapped or not)
+              -- co1     :: kind(tv1) ~N ki1
+              -- homo_co :: ki2 ~N kind(tv1)
+             homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1
+             rhs'    = mkCastTy xi2 homo_co     -- :: kind(tv1)
+             ps_rhs' = mkCastTy ps_xi2 homo_co  -- :: kind(tv1)
+             rhs_co  = mkTcGReflLeftCo role xi2 homo_co
+               -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2
+
+             lhs'   = mkTyVarTy tv1       -- :: kind(tv1)
+             lhs_co = mkTcGReflRightCo role lhs' co1
+               -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1)
+
+       ; traceTcS "Hetero equality gives rise to given kind equality"
+           (ppr kind_ev <+> dcolon <+> ppr kind_pty)
+       ; emitWorkNC [kind_ev]
+       ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co
+       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
+
+  -- See Note [Equalities with incompatible kinds]
+  | otherwise   -- Wanted and Derived
+                  -- NB: all kind equalities are Nominal
+  = do { emitNewDerivedEq kind_loc Nominal ki1 ki2
+             -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)
+       ; traceTcS "Hetero equality gives rise to derived kind equality" $
+           ppr ev
+       ; continueWith (mkIrredCt ev) }
+
+  where
+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
+    kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc
+
+    loc  = ctev_loc ev
+    role = eqRelRole eq_rel
+
+-- guaranteed that typeKind lhs == typeKind rhs
+canEqTyVarHomo :: CtEvidence
+               -> EqRel -> SwapFlag
+               -> TcTyVar                -- lhs: tv1
+               -> TcType                 -- pretty lhs
+               -> TcType -> TcType       -- rhs (might not be flat)
+               -> TcS (StopOrContinue Ct)
+canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
+  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
+  , tv1 == tv2
+  = canEqReflexive ev eq_rel (mkTyVarTy tv1)
+    -- we don't need to check co because it must be reflexive
+
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  , swapOverTyVars tv1 tv2
+  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
          -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
          -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
          -- Flatten the RHS less vigorously, to avoid gratuitous flattening
          -- True <=> xi2 should not itself be a type-function application
+
+       ; let role    = eqRelRole eq_rel
+             sym_co2 = mkTcSymCo co2
+             ty1     = mkTyVarTy tv1
+             new_lhs = ty1 `mkCastTy` sym_co2
+             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2
+
+             new_rhs = mkTyVarTy tv2
+             rhs_co  = mkTcGReflRightCo role new_rhs co2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+
        ; dflags <- getDynFlags
-       ; canEqTyVar2 dflags ev eq_rel (flipSwap swapped) tv2 ps_ty1 }
+       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }
 
-canEqTyVar ev eq_rel swapped tv1 _ _ ps_ty2
+canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2
   = do { dflags <- getDynFlags
        ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }
 
+-- The RHS here is either not a casted tyvar, or it's a tyvar but we want
+-- to rewrite the LHS to the RHS (as per swapOverTyVars)
 canEqTyVar2 :: DynFlags
             -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)
             -> EqRel
             -> SwapFlag
-            -> TcTyVar      -- lhs, flat
-            -> TcType       -- rhs, flat
+            -> TcTyVar                  -- lhs = tv, flat
+            -> TcType                   -- rhs
             -> TcS (StopOrContinue Ct)
 -- LHS is an inert type variable,
 -- and RHS is fully rewritten, but with type synonyms
 -- preserved as much as possible
-
-canEqTyVar2 dflags ev eq_rel swapped tv1 xi2
-  | Just xi2' <- metaTyVarUpdateOK dflags tv1 xi2  -- No occurs check
+canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
+  | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check
      -- Must do the occurs check even on tyvar/tyvar
      -- equalities, in case have  x ~ (y :: ..x...)
      -- Trac #12593
-  = rewriteEqEvidence ev swapped xi1 xi2' co1 co2
-    `andWhenContinue` \ new_ev ->
-    homogeniseRhsKind new_ev eq_rel xi1 xi2' $ \new_new_ev xi2'' ->
-    CTyEqCan { cc_ev = new_new_ev, cc_tyvar = tv1
-             , cc_rhs = xi2'', cc_eq_rel = eq_rel }
+  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
+       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
+                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }
 
   | otherwise  -- For some reason (occurs check, or forall) we can't unify
                -- We must not use it for further rewriting!
-  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr xi2)
-       ; rewriteEqEvidence ev swapped xi1 xi2 co1 co2
-         `andWhenContinue` \ new_ev ->
-         if isInsolubleOccursCheck eq_rel tv1 xi2
-         then do { emitInsoluble (mkNonCanonical new_ev)
+  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
+       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
+       ; if isInsolubleOccursCheck eq_rel tv1 rhs
+         then continueWith (mkInsolubleCt new_ev)
              -- If we have a ~ [a], it is not canonical, and in particular
              -- we don't want to rewrite existing inerts with it, otherwise
              -- we'd risk divergence in the constraint solver
-                 ; stopWith new_ev "Occurs check" }
 
+         else continueWith (mkIrredCt new_ev) }
              -- A representational equality with an occurs-check problem isn't
              -- insoluble! For example:
              --   a ~R b a
              -- We might learn that b is the newtype Id.
              -- But, the occurs-check certainly prevents the equality from being
              -- canonical, and we might loop if we were to use it in rewriting.
-         else do { traceTcS "Possibly-soluble occurs check"
-                           (ppr xi1 $$ ppr xi2)
-                 ; continueWith (CIrredEvCan { cc_ev = new_ev }) } }
   where
     role = eqRelRole eq_rel
-    xi1  = mkTyVarTy tv1
-    co1  = mkTcReflCo role xi1
-    co2  = mkTcReflCo role xi2
+
+    lhs = mkTyVarTy tv1
+
+    rewrite_co1  = mkTcReflCo role lhs
+    rewrite_co2  = mkTcReflCo role rhs
 
 -- | Solve a reflexive equality constraint
 canEqReflexive :: CtEvidence    -- ty ~ ty
@@ -1471,79 +2038,10 @@ canEqReflexive :: CtEvidence    -- ty ~ ty
                -> TcType        -- ty
                -> TcS (StopOrContinue Ct)   -- always Stop
 canEqReflexive ev eq_rel ty
-  = do { setEvBindIfWanted ev (EvCoercion $
+  = do { setEvBindIfWanted ev (evCoercion $
                                mkTcReflCo (eqRelRole eq_rel) ty)
        ; stopWith ev "Solved by reflexivity" }
 
--- See Note [Equalities with incompatible kinds]
-homogeniseRhsKind :: CtEvidence -- ^ the evidence to homogenise
-                  -> EqRel
-                  -> TcType              -- ^ original LHS
-                  -> Xi                  -- ^ original RHS
-                  -> (CtEvidence -> Xi -> Ct)
-                           -- ^ how to build the homogenised constraint;
-                           -- the 'Xi' is the new RHS
-                  -> TcS (StopOrContinue Ct)
-homogeniseRhsKind ev eq_rel lhs rhs build_ct
-  | k1 `tcEqType` k2
-  = continueWith (build_ct ev rhs)
-
-  | CtGiven { ctev_evar = evar } <- ev
-    -- tm :: (lhs :: k1) ~ (rhs :: k2)
-  = do { kind_ev_id <- newBoundEvVarId kind_pty
-                                       (EvCoercion $
-                                        mkTcKindCo $ mkTcCoVarCo evar)
-           -- kind_ev_id :: (k1 :: *) ~# (k2 :: *)
-       ; let kind_ev = CtGiven { ctev_pred = kind_pty
-                               , ctev_evar = kind_ev_id
-                               , ctev_loc  = kind_loc }
-             homo_co = mkSymCo $ mkCoVarCo kind_ev_id
-             rhs'    = mkCastTy rhs homo_co
-       ; traceTcS "Hetero equality gives rise to given kind equality"
-           (ppr kind_ev_id <+> dcolon <+> ppr kind_pty)
-       ; emitWorkNC [kind_ev]
-       ; type_ev <- newGivenEvVar loc
-                      ( mkTcEqPredLikeEv ev lhs rhs'
-                      , EvCoercion $
-                        mkTcCoherenceRightCo (mkTcCoVarCo evar) homo_co )
-          -- type_ev :: (lhs :: k1) ~ ((rhs |> sym kind_ev_id) :: k1)
-       ; continueWith (build_ct type_ev rhs') }
-
-  | otherwise   -- Wanted and Derived. See Note [No derived kind equalities]
-    -- evar :: (lhs :: k1) ~ (rhs :: k2)
-  = do { kind_co <- emitNewWantedEq kind_loc Nominal k1 k2
-             -- kind_ev :: (k1 :: *) ~ (k2 :: *)
-       ; traceTcS "Hetero equality gives rise to wanted kind equality" $
-           ppr (kind_co)
-       ; let homo_co   = mkSymCo kind_co
-           -- homo_co :: k2 ~ k1
-             rhs'      = mkCastTy rhs homo_co
-       ; case ev of
-           CtGiven {} -> panic "homogeniseRhsKind"
-           CtDerived {} -> continueWith (build_ct (ev { ctev_pred = homo_pred })
-                                                  rhs')
-             where homo_pred = mkTcEqPredLikeEv ev lhs rhs'
-           CtWanted { ctev_dest = dest } -> do
-             { (type_ev, hole_co) <- newWantedEq loc role lhs rhs'
-                  -- type_ev :: (lhs :: k1) ~ (rhs |> sym kind_co :: k1)
-             ; setWantedEq dest
-                           (hole_co `mkTransCo`
-                            (mkReflCo role rhs
-                             `mkCoherenceLeftCo` homo_co))
-
-                -- dest := hole ; <rhs> |> homo_co :: (lhs :: k1) ~ (rhs :: k2)
-             ; continueWith (build_ct type_ev rhs') }}
-
-  where
-    k1 = typeKind lhs
-    k2 = typeKind rhs
-
-    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind k1 k2
-    kind_loc = mkKindLoc lhs rhs loc
-
-    loc  = ctev_loc ev
-    role = eqRelRole eq_rel
-
 {-
 Note [Canonical orientation for tyvar/tyvar equality constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1560,66 +2058,85 @@ canEqTyVarTyVar, are these
    number) on the left, so there is the best chance of unifying it
         alpha[3] ~ beta[2]
 
- * If both are meta-tyvars and both at the same level, put a SigTv
+ * If both are meta-tyvars and both at the same level, put a TyVarTv
    on the right if possible
         alpha[2] ~ beta[2](sig-tv)
-   That way, when we unify alpha := beta, we don't lose the SigTv flag.
+   That way, when we unify alpha := beta, we don't lose the TyVarTv flag.
 
  * Put a meta-tv with a System Name on the left if possible so it
    gets eliminated (improves error messages)
 
  * If one is a flatten-skolem, put it on the left so that it is
-   substituted out  Note [Elminate flat-skols]
+   substituted out  Note [Eliminate flat-skols] in TcUinfy
         fsk ~ a
 
-Note [Avoid unnecessary swaps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we swap without actually improving matters, we can get an infnite loop.
-Consider
-    work item:  a ~ b
-   inert item:  b ~ c
-We canonicalise the work-time to (a ~ c).  If we then swap it before
-aeding to the inert set, we'll add (c ~ a), and therefore kick out the
-inert guy, so we get
-   new work item:  b ~ c
-   inert item:     c ~ a
-And now the cycle just repeats
-
-Note [Eliminate flat-skols]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have  [G] Num (F [a])
-then we flatten to
-     [G] Num fsk
-     [G] F [a] ~ fsk
-where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
-      type instance F [a] = a
-then we'll reduce the second constraint to
-     [G] a ~ fsk
-and then replace all uses of 'a' with fsk.  That's bad because
-in error messages intead of saying 'a' we'll say (F [a]).  In all
-places, including those where the programmer wrote 'a' in the first
-place.  Very confusing!  See Trac #7862.
-
-Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
-the fsk.
-
 Note [Equalities with incompatible kinds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-canEqLeaf is about to make a CTyEqCan or CFunEqCan; but both have the
-invariant that LHS and RHS satisfy the kind invariants for CTyEqCan,
-CFunEqCan.  What if we try to unify two things with incompatible
-kinds?
+What do we do when we have an equality
+
+  (tv :: k1) ~ (rhs :: k2)
+
+where k1 and k2 differ? This Note explores this treacherous area.
+
+First off, the question above is slightly the wrong question. Flattening
+a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening
+the kind might introduce a cast. So we might have a casted tyvar on the
+left. We thus revise our test case to
+
+  (tv |> co :: k1) ~ (rhs :: k2)
+
+We must proceed differently here depending on whether we have a Wanted
+or a Given. Consider this:
 
-eg    a ~ b  where a::*, b::*->*
-or    a ~ b  where a::*, b::k, k is a kind variable
+ [W] w :: (alpha :: k) ~ (Int :: Type)
 
-The CTyEqCan compatKind invariant is important.  If we make a CTyEqCan
-for a~b, then we might well *substitute* 'b' for 'a', and that might make
-a well-kinded type ill-kinded; and that is bad (eg typeKind can crash, see
-Trac #7696).
+where k is a skolem. One possible way forward is this:
 
-So instead for these ill-kinded equalities we homogenise the RHS of the
-equality, emitting new constraints as necessary.
+ [W] co :: k ~ Type
+ [W] w :: (alpha :: k) ~ (Int |> sym co :: k)
+
+The next step will be to unify
+
+  alpha := Int |> sym co
+
+Now, consider what error we'll report if we can't solve the "co"
+wanted. Its CtOrigin is the w wanted... which now reads (after zonking)
+Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which
+is embarrassing. See #11198 for more tales of destruction.
+
+The reason for this odd behavior is much the same as
+Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the
+new `co` is a Wanted.
+
+   The solution is then not to use `co` to "rewrite" -- that is, cast
+   -- `w`, but instead to keep `w` heterogeneous and
+   irreducible. Given that we're not using `co`, there is no reason to
+   collect evidence for it, so `co` is born a Derived, with a CtOrigin
+   of KindEqOrigin.
+
+When the Derived is solved (by unification), the original wanted (`w`)
+will get kicked out.
+
+Note that, if we had [G] co1 :: k ~ Type available, then none of this code would
+trigger, because flattening would have rewritten k to Type. That is,
+`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar
+case will trigger, correctly rewriting alpha to (Int |> sym co1).
+
+Successive canonicalizations of the same Wanted may produce
+duplicate Deriveds. Similar duplications can happen with fundeps, and there
+seems to be no easy way to avoid. I expect this case to be rare.
+
+For Givens, this problem doesn't bite, so a heterogeneous Given gives
+rise to a Given kind equality. No Deriveds here. We thus homogenise
+the Given (see the "homo_co" in the Given case in canEqTyVar) and
+carry on with a homogeneous equality constraint.
+
+Separately, I (Richard E) spent some time pondering what to do in the case
+that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2
+differ. Note that the tv is the same. (This case is handled as the first
+case in canEqTyVarHomo.) At one point, I thought we could solve this limited
+form of heterogeneous Wanted, but I then reconsidered and now treat this case
+just like any other heterogeneous Wanted.
 
 Note [Type synonyms and canonicalization]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1749,7 +2266,7 @@ rewriteEvidence old_ev@(CtDerived {}) new_pred _co
     -- rewriteEvidence to put the isTcReflCo test first!
     -- Why?  Because for *Derived* constraints, c, the coercion, which
     -- was produced by flattening, may contain suspended calls to
-    -- (ctEvTerm c), which fails for Derived constraints.
+    -- (ctEvExpr c), which fails for Derived constraints.
     -- (Getting this wrong caused Trac #7384.)
     continueWith (old_ev { ctev_pred = new_pred })
 
@@ -1757,12 +2274,12 @@ rewriteEvidence old_ev new_pred co
   | isTcReflCo co -- See Note [Rewriting with Refl]
   = continueWith (old_ev { ctev_pred = new_pred })
 
-rewriteEvidence ev@(CtGiven { ctev_evar = old_evar , ctev_loc = loc }) new_pred co
+rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
   = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
        ; continueWith new_ev }
   where
     -- mkEvCast optimises ReflCo
-    new_tm = mkEvCast (EvId old_evar) (tcDowngradeRole Representational
+    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
                                                        (ctEvRole ev)
                                                        (mkTcSymCo co))
 
@@ -1771,8 +2288,8 @@ rewriteEvidence ev@(CtWanted { ctev_dest = dest
   = do { mb_new_ev <- newWanted loc new_pred
        ; MASSERT( tcCoercionRole co == ctEvRole ev )
        ; setWantedEvTerm dest
-                   (mkEvCast (getEvTerm mb_new_ev)
-                             (tcDowngradeRole Representational (ctEvRole ev) co))
+            (mkEvCast (getEvExpr mb_new_ev)
+                      (tcDowngradeRole Representational (ctEvRole ev) co))
        ; case mb_new_ev of
             Fresh  new_ev -> continueWith new_ev
             Cached _      -> stopWith ev "Cached wanted" }
@@ -1785,7 +2302,7 @@ rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swap
                                         -- Should be zonked, because we use typeKind on nlhs/nrhs
                   -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs
                   -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs
-                  -> TcS (StopOrContinue CtEvidence)  -- Of type nlhs ~ nrhs
+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
 -- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)
 -- we generate
 -- If not swapped
@@ -1803,19 +2320,18 @@ rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swap
 -- It's all a form of rewwriteEvidence, specialised for equalities
 rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
   | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived
-  = continueWith (old_ev { ctev_pred = new_pred })
+  = return (old_ev { ctev_pred = new_pred })
 
   | NotSwapped <- swapped
   , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]
   , isTcReflCo rhs_co
-  = continueWith (old_ev { ctev_pred = new_pred })
+  = return (old_ev { ctev_pred = new_pred })
 
   | CtGiven { ctev_evar = old_evar } <- old_ev
-  = do { let new_tm = EvCoercion (lhs_co
+  = do { let new_tm = evCoercion (lhs_co
                                   `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
                                   `mkTcTransCo` mkTcSymCo rhs_co)
-       ; new_ev <- newGivenEvVar loc' (new_pred, new_tm)
-       ; continueWith new_ev }
+       ; newGivenEvVar loc' (new_pred, new_tm) }
 
   | CtWanted { ctev_dest = dest } <- old_ev
   = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs
@@ -1825,7 +2341,7 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
                   `mkTransCo` rhs_co
        ; setWantedEq dest co
        ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
-       ; continueWith new_ev }
+       ; return new_ev }
 
   | otherwise
   = panic "rewriteEvidence"
@@ -1845,7 +2361,7 @@ When decomposing equalities we often create new wanted constraints for
 Similar remarks apply for Derived.
 
 Rather than making an equality test (which traverses the structure of the
-type, perhaps fruitlessly, unifyWanted traverses the common structure, and
+type, perhaps fruitlessly), unifyWanted traverses the common structure, and
 bales out when it finds a difference by creating a new Wanted constraint.
 But where it succeeds in finding common structure, it just builds a coercion
 to reflect it.
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index a3e9549a1c..118a219af6 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -14,11 +14,14 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
                     tcClassMinimalDef,
                     HsSigFun, mkHsSigFun,
                     tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,
                     tcATDefault
                   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import TcEnv
 import TcSigs
@@ -136,16 +139,20 @@ tcClassSigs clas sigs def_methods
        ; traceTc "tcClassSigs 2" (ppr clas)
        ; return op_info }
   where
-    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]
-    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig True  nm ty) <- sigs]
+    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
+    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]
     dm_bind_names :: [Name] -- These ones have a value binding in the class decl
     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 
+    skol_info = TyConSkol ClassFlavour clas
+
     tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
            -> TcM [TcMethInfo]
     tc_sig gen_dm_env (op_names, op_hs_ty)
       = do { traceTc "ClsSig 1" (ppr op_names)
-           ; op_ty <- tcClassSigType op_names op_hs_ty   -- Class tyvars already in scope
+           ; op_ty <- tcClassSigType skol_info op_names op_hs_ty
+                   -- Class tyvars already in scope
+
            ; traceTc "ClsSig 2" (ppr op_names)
            ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
            where
@@ -154,7 +161,7 @@ tcClassSigs clas sigs def_methods
                   | otherwise                               = Nothing
 
     tc_gen_sig (op_names, gen_hs_ty)
-      = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
+      = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
            ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
 
 {-
@@ -191,6 +198,9 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 
         ; let tc_item = tcDefMeth clas clas_tyvars this_dict
                                   default_binds sig_fn prag_fn
+                   -- tcExtendTyVarEnv here (instead of scopeTyVars) is OK:
+                   -- the tcDefMeth calls checkConstraints to bump the TcLevel
+                   -- and make the implication constraint
         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                       mapM tc_item op_items
 
@@ -273,19 +283,22 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
                                         , sig_loc   = getLoc (hsSigType hs_ty) }
 
        ; (ev_binds, (tc_bind, _))
-               <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
+               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
                   tcPolyCheck no_prag_fn local_dm_sig
                               (L bind_loc lm_bind)
 
-       ; let export = ABE { abe_poly   = global_dm_id
-                           , abe_mono  = local_dm_id
-                           , abe_wrap  = idHsWrapper
-                           , abe_prags = IsDefaultMethod }
-             full_bind = AbsBinds { abs_tvs      = tyvars
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = global_dm_id
+                          , abe_mono  = local_dm_id
+                          , abe_wrap  = idHsWrapper
+                          , abe_prags = IsDefaultMethod }
+             full_bind = AbsBinds { abs_ext      = noExt
+                                  , abs_tvs      = tyvars
                                   , abs_ev_vars  = [this_dict]
                                   , abs_exports  = [export]
                                   , abs_ev_binds = [ev_binds]
-                                  , abs_binds    = tc_bind }
+                                  , abs_binds    = tc_bind
+                                  , abs_sig      = True }
 
        ; return (unitBag (L bind_loc full_bind)) }
 
@@ -347,8 +360,8 @@ mkHsSigFun sigs = lookupNameEnv env
     env = mkHsSigEnv get_classop_sig sigs
 
     get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
-    get_classop_sig  (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)
-    get_classop_sig  _                             = Nothing
+    get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
+    get_classop_sig  _                               = Nothing
 
 ---------------------------
 findMethodBind  :: Name                 -- Selector
@@ -373,8 +386,8 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
 findMinimalDef = firstJusts . map toMinimalDef
   where
     toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
-    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
-    toMinimalDef _                             = Nothing
+    toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
+    toMinimalDef _                               = Nothing
 
 {-
 Note [Polymorphic methods]
@@ -460,9 +473,25 @@ warningMinimalDefIncomplete mindef
          , nest 2 (pprBooleanFormulaNice mindef)
          , text "but there is no default implementation." ]
 
-tcATDefault :: Bool -- If a warning should be emitted when a default instance
-                    -- definition is not provided by the user
-            -> SrcSpan
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = instDeclCtxt3 cls tys
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+instDeclCtxt3 :: Class -> [Type] -> SDoc
+instDeclCtxt3 cls cls_tys
+  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+tcATDefault :: SrcSpan
             -> TCvSubst
             -> NameSet
             -> ClassATItem
@@ -470,7 +499,7 @@ tcATDefault :: Bool -- If a warning should be emitted when a default instance
 -- ^ Construct default instances for any associated types that
 -- aren't given a user definition
 -- Returns [] or singleton
-tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
+tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
   -- User supplied instances ==> everything is OK
   | tyConName fam_tc `elemNameSet` defined_ats
   = return []
@@ -502,7 +531,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
 
    -- No defaults ==> generate a warning
   | otherwise  -- defs = Nothing
-  = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
+  = do { warnMissingAT (tyConName fam_tc)
        ; return [] }
   where
     subst_tv subst tc_tv
diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs
index 8d005a09e6..d091e9c156 100644
--- a/compiler/typecheck/TcDefaults.hs
+++ b/compiler/typecheck/TcDefaults.hs
@@ -8,6 +8,8 @@
 
 module TcDefaults ( tcDefaults ) where
 
+import GhcPrelude
+
 import HsSyn
 import Class
 import TcRnMonad
@@ -40,10 +42,10 @@ tcDefaults []
         -- one group, only for the next group to ignore them and install
         -- defaultDefaultTys
 
-tcDefaults [L _ (DefaultDecl [])]
+tcDefaults [L _ (DefaultDecl _ [])]
   = return (Just [])            -- Default declaration specifying no types
 
-tcDefaults [L locn (DefaultDecl mono_tys)]
+tcDefaults [L locn (DefaultDecl _ mono_tys)]
   = setSrcSpan locn                     $
     addErrCtxt defaultDeclCtxt          $
     do  { ovl_str   <- xoptM LangExt.OverloadedStrings
@@ -61,16 +63,17 @@ tcDefaults [L locn (DefaultDecl mono_tys)]
 
         ; return (Just tau_tys) }
 
-tcDefaults decls@(L locn (DefaultDecl _) : _)
+tcDefaults decls@(L locn (DefaultDecl _ _) : _)
   = setSrcSpan locn $
     failWithTc (dupDefaultDeclErr decls)
+tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"
 
 
 tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
 tc_default_ty deflt_clss hs_ty
  = do   { (ty, _kind) <- solveEqualities $
                          tcLHsType hs_ty
-        ; ty <- zonkTcTypeToType emptyZonkEnv ty   -- establish Type invariants
+        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
         ; checkValidType DefaultDeclCtxt ty
 
         -- Check that the type is an instance of at least one of the deflt_clss
@@ -91,11 +94,14 @@ defaultDeclCtxt :: SDoc
 defaultDeclCtxt = text "When checking the types in a default declaration"
 
 dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
-dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
+dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
   = hang (text "Multiple default declarations")
        2 (vcat (map pp dup_things))
   where
-    pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn
+    pp (L locn (DefaultDecl _ _))
+      = text "here was another default declaration" <+> ppr locn
+    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"
 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
 
 badDefaultTy :: Type -> [Class] -> SDoc
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 056bc9bfaf..6f749fc60f 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -13,6 +13,8 @@ module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import DynFlags
 
@@ -21,14 +23,15 @@ import FamInst
 import TcDerivInfer
 import TcDerivUtils
 import TcValidity( allDistinctTyVars )
-import TcClassDcl( tcATDefault, tcMkDeclCtxt )
+import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
 import TcEnv
 import TcGenDeriv                       -- Deriv stuff
+import TcValidity
 import InstEnv
 import Inst
 import FamInstEnv
 import TcHsType
-import TcMType
+import TyCoRep
 
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
@@ -38,7 +41,6 @@ import RnSource   ( addTcgDUs )
 import Avail
 
 import Unify( tcUnifyTy )
-import BasicTypes ( DerivStrategy(..) )
 import Class
 import Type
 import ErrUtils
@@ -63,6 +65,8 @@ import FV (fvVarList, unionFV, mkFVs)
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
 import Data.List
 
 {-
@@ -333,7 +337,7 @@ renameDeriv is_boot inst_infos bagBinds
         -- before renaming the instances themselves
         ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
         ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
-        ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
+        ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)
         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
         ; let bndrs = collectHsValBinders rn_aux_lhs
         ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
@@ -580,7 +584,8 @@ same set of clause-derived classes.
 
 ------------------------------------------------------------------
 -- | Process a single class in a `deriving` clause.
-deriveClause :: TyCon -> Maybe DerivStrategy -> LHsSigType GhcRn -> SDoc
+deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
+             -> LHsSigType GhcRn -> SDoc
              -> TcM (Maybe EarlyDerivSpec)
 deriveClause rep_tc mb_strat pred err_ctxt
   = addErrCtxt err_ctxt $
@@ -603,31 +608,70 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
 --
 -- This returns a Maybe because the user might try to derive Typeable, which is
 -- a no-op nowadays.
-deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
+deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
-       ; let deriv_strat = fmap unLoc deriv_strat'
+       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat
+             ctxt           = TcType.InstDeclCtxt True
        ; traceTc "Deriving strategy (standalone deriving)" $
-           vcat [ppr deriv_strat, ppr deriv_ty]
-       ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
+           vcat [ppr mb_deriv_strat, ppr deriv_ty]
+       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
+           <- tcDerivStrategy ctxt mb_deriv_strat $ do
+                (tvs, deriv_ctxt, cls, inst_tys)
+                  <- tcStandaloneDerivInstType ctxt deriv_ty
+                pure (tvs, (deriv_ctxt, cls, inst_tys))
+       ; checkTc (not (null inst_tys')) derivingNullaryErr
+       ; let inst_ty' = last inst_tys'
+         -- See Note [Unify kinds in deriving]
+       ; (tvs, deriv_ctxt, inst_tys) <-
+           case mb_deriv_strat' of
+             -- Perform an additional unification with the kind of the `via`
+             -- type and the result of the previous kind unification.
+             Just (ViaStrategy via_ty) -> do
+               let via_kind     = typeKind via_ty
+                   inst_ty_kind = typeKind inst_ty'
+                   mb_match     = tcUnifyTy inst_ty_kind via_kind
+
+               checkTc (isJust mb_match)
+                       (derivingViaKindErr cls inst_ty_kind
+                                           via_ty via_kind)
+
+               let Just kind_subst = mb_match
+                   ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                   -- See Note [Unification of two kind variables in deriving]
+                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
+                                        && not (v `elemVarSet` ki_subst_range))
+                                          tvs'
+                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
+                   (final_deriv_ctxt, final_deriv_ctxt_tys)
+                     = case deriv_ctxt' of
+                         InferContext wc -> (InferContext wc, [])
+                         SupplyContext theta ->
+                           let final_theta = substTheta subst theta
+                           in (SupplyContext final_theta, final_theta)
+                   final_inst_tys   = substTys subst inst_tys'
+                   final_tvs        = tyCoVarsOfTypesWellScoped $
+                                      final_deriv_ctxt_tys ++ final_inst_tys
+               pure (final_tvs, final_deriv_ctxt, final_inst_tys)
+
+             _ -> pure (tvs', deriv_ctxt', inst_tys')
+       ; let cls_tys = take (length inst_tys - 1) inst_tys
+             inst_ty = last inst_tys
        ; traceTc "Standalone deriving;" $ vcat
               [ text "tvs:" <+> ppr tvs
-              , text "theta:" <+> ppr theta
+              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'
+              , text "deriv_ctxt:" <+> ppr deriv_ctxt
               , text "cls:" <+> ppr cls
               , text "tys:" <+> ppr inst_tys ]
                 -- C.f. TcInstDcls.tcLocalInstDecl1
-       ; checkTc (not (null inst_tys)) derivingNullaryErr
-
-       ; let cls_tys = take (length inst_tys - 1) inst_tys
-             inst_ty = last inst_tys
        ; traceTc "Standalone deriving:" $ vcat
               [ text "class:" <+> ppr cls
               , text "class types:" <+> ppr cls_tys
               , text "type:" <+> ppr inst_ty ]
 
        ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
-                              inst_ty deriv_strat msg)
+                              inst_ty mb_deriv_strat' msg)
 
        ; case tcSplitTyConApp_maybe inst_ty of
            Just (tc, tc_args)
@@ -635,22 +679,63 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
               -> do warnUselessTypeable
                     return Nothing
 
-              | isUnboxedTupleTyCon tc
-              -> bale_out $ unboxedTyConErr "tuple"
-
-              | isUnboxedSumTyCon tc
-              -> bale_out $ unboxedTyConErr "sum"
-
-              | isAlgTyCon tc || isDataFamilyTyCon tc  -- All other classes
-              -> do { spec <- mkEqnHelp (fmap unLoc overlap_mode)
-                                        tvs cls cls_tys tc tc_args
-                                        (Just theta) deriv_strat
-                    ; return $ Just spec }
+              | otherwise
+              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
+                                    tvs cls cls_tys tc tc_args
+                                    deriv_ctxt mb_deriv_strat'
 
            _  -> -- Complain about functions, primitive types, etc,
                  bale_out $
                  text "The last argument of the instance must be a data or newtype application"
         }
+deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"
+
+-- Typecheck the type in a standalone deriving declaration.
+--
+-- This may appear dense, but it's mostly huffing and puffing to recognize
+-- the special case of a type with an extra-constraints wildcard context, e.g.,
+--
+--   deriving instance _ => Eq (Foo a)
+--
+-- If there is such a wildcard, we typecheck this as if we had written
+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
+-- as the 'DerivContext', where loc is the location of the wildcard used for
+-- error reporting. This indicates that we should infer the context as if we
+-- were deriving Eq via a deriving clause
+-- (see Note [Inferring the instance context] in TcDerivInfer).
+--
+-- If there is no wildcard, then proceed as normal, and instead return
+-- @'SupplyContext' theta@, where theta is the typechecked context.
+--
+-- Note that this will never return @'InferContext' 'Nothing'@, as that can
+-- only happen with @deriving@ clauses.
+tcStandaloneDerivInstType
+  :: UserTypeCtxt -> LHsSigWcType GhcRn
+  -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType ctxt
+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
+                                       , hsib_body   = deriv_ty_body })})
+  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+  , L _ [wc_pred] <- theta
+  , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
+  = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
+         <- tcHsClsInstType ctxt $
+            HsIB { hsib_ext = vars
+                 , hsib_body
+                     = L (getLoc deriv_ty_body) $
+                       HsForAllTy { hst_bndrs = tvs
+                                  , hst_xforall = noExt
+                                  , hst_body  = rho }}
+       pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
+  | otherwise
+  = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
+         <- tcHsClsInstType ctxt deriv_ty
+       pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
+
+tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
+  = panic "tcStandaloneDerivInstType"
+tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
+  = panic "tcStandaloneDerivInstType"
 
 warnUselessTypeable :: TcM ()
 warnUselessTypeable
@@ -662,7 +747,7 @@ warnUselessTypeable
 ------------------------------------------------------------------
 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
                                              --   Can be a data instance, hence [Type] args
-             -> Maybe DerivStrategy          -- The optional deriving strategy
+             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy
              -> LHsSigType GhcRn             -- The deriving predicate
              -> TcM (Maybe EarlyDerivSpec)
 -- The deriving clause of a data or newtype declaration
@@ -670,11 +755,14 @@ deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
 --
 -- This returns a Maybe because the user might try to derive Typeable, which is
 -- a no-op nowadays.
-deriveTyData tvs tc tc_args deriv_strat deriv_pred
-  = setSrcSpan (getLoc (hsSigType deriv_pred)) $  -- Use loc of the 'deriving' item
-    do  { (deriv_tvs, cls, cls_tys, cls_arg_kinds)
+deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $
+    -- Use loc of the 'deriving' item
+    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))
+                   -- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars.
+                   -- Their kinds are fully settled. No need to worry about skolem
+                   -- escape.
                 <- tcExtendTyVarEnv tvs $
-                   tcHsDeriv deriv_pred
                 -- Deriving preds may (now) mention
                 -- the type variables for the type constructor, hence tcExtendTyVarenv
                 -- The "deriv_pred" is a LHsType to take account of the fact that for
@@ -683,6 +771,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
                 -- Typeable is special, because Typeable :: forall k. k -> Constraint
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
+                     tcDerivStrategy TcType.DerivClauseCtxt mb_deriv_strat $
+                     tcHsDeriv deriv_pred
+
         ; when (cls_arg_kinds `lengthIsNot` 1) $
             failWithTc (nonUnaryErr deriv_pred)
         ; let [cls_arg_kind] = cls_arg_kinds
@@ -710,25 +801,56 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
         ; checkTc (enough_args && isJust mb_match)
                   (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
 
-        ; let Just kind_subst = mb_match
-              ki_subst_range  = getTCvSubstRangeFVs kind_subst
-              all_tkvs        = toposortTyVars $
-                                fvVarList $ unionFV
-                                  (tyCoFVsOfTypes tc_args_to_keep)
-                                  (FV.mkFVs deriv_tvs)
-              -- See Note [Unification of two kind variables in deriving]
-              unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
-                                      && not (v `elemVarSet` ki_subst_range))
-                                       all_tkvs
-              (subst, _)      = mapAccumL substTyVarBndr
-                                          kind_subst unmapped_tkvs
-              final_tc_args   = substTys subst tc_args_to_keep
-              final_cls_tys   = substTys subst cls_tys
-              tkvs            = tyCoVarsOfTypesWellScoped $
-                                final_cls_tys ++ final_tc_args
+        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'
+                = (final_tkvs, final_cls_tys, final_tc_args)
+                where
+                  ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                  -- See Note [Unification of two kind variables in deriving]
+                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
+                                         && not (v `elemVarSet` ki_subst_range))
+                                           tkvs'
+                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs
+                  final_tc_args   = substTys subst tc_args'
+                  final_cls_tys   = substTys subst cls_tys'
+                  final_tkvs      = tyCoVarsOfTypesWellScoped $
+                                    final_cls_tys ++ final_tc_args
+
+        ; let tkvs = toposortTyVars $ fvVarList $
+                     unionFV (tyCoFVsOfTypes tc_args_to_keep)
+                             (FV.mkFVs deriv_tvs)
+              Just kind_subst = mb_match
+              (tkvs', final_cls_tys', final_tc_args')
+                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep
+
+          -- See Note [Unify kinds in deriving]
+        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
+            case mb_deriv_strat' of
+              -- Perform an additional unification with the kind of the `via`
+              -- type and the result of the previous kind unification.
+              Just (ViaStrategy via_ty) -> do
+                let final_via_ty   = via_ty
+                    final_via_kind = typeKind final_via_ty
+                    final_inst_ty_kind
+                              = typeKind (mkTyConApp tc final_tc_args')
+                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind
+
+                checkTc (isJust via_match)
+                        (derivingViaKindErr cls final_inst_ty_kind
+                                            final_via_ty final_via_kind)
+
+                let Just via_subst = via_match
+                    (final_tkvs, final_cls_tys, final_tc_args)
+                      = propagate_subst via_subst tkvs'
+                                        final_cls_tys' final_tc_args'
+                pure ( final_tkvs, final_cls_tys, final_tc_args
+                     , Just $ ViaStrategy $ substTy via_subst via_ty
+                     )
+
+              _ -> pure ( tkvs', final_cls_tys', final_tc_args'
+                        , mb_deriv_strat' )
 
         ; traceTc "Deriving strategy (deriving clause)" $
-            vcat [ppr deriv_strat, ppr deriv_pred]
+            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]
 
         ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
                                        , ppr deriv_pred
@@ -739,8 +861,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
 
         ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
 
+        ; let final_tc_app = mkTyConApp tc final_tc_args
         ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
-                  (derivingEtaErr cls final_cls_tys (mkTyConApp tc final_tc_args))
+                  (derivingEtaErr cls final_cls_tys final_tc_app)
                 -- Check that
                 --  (a) The args to drop are all type variables; eg reject:
                 --              data instance T a Int = .... deriving( Monad )
@@ -756,9 +879,14 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
                 -- expand any type synonyms.
                 -- See Note [Eta-reducing type synonyms]
 
+        ; checkValidInstHead DerivClauseCtxt cls $
+                             final_cls_tys ++ [final_tc_app]
+                -- Check that we aren't deriving an instance of a magical
+                -- type like (~) or Coercible (#14916).
+
         ; spec <- mkEqnHelp Nothing tkvs
                             cls final_cls_tys tc final_tc_args
-                            Nothing deriv_strat
+                            (InferContext Nothing) final_mb_deriv_strat
         ; traceTc "derivTyData" (ppr spec)
         ; return $ Just spec } }
 
@@ -835,11 +963,11 @@ generated instance of:
 
     instance (k ~ *) => Functor (T k) where
 
-But this does not typecheck as the result of a -XTypeInType design decision:
-kind equalities are not allowed to be bound in types, only terms. But in
-essence, the two instance declarations are entirely equivalent, since even
-though (T k) matches any kind k, the only possibly value for k is *, since
-anything else is ill-typed. As a result, we can just as comfortably use (T *).
+But this does not typecheck by design: kind equalities are not allowed to be
+bound in types, only terms. But in essence, the two instance declarations are
+entirely equivalent, since even though (T k) matches any kind k, the only
+possibly value for k is *, since anything else is ill-typed. As a result, we can
+just as comfortably use (T *).
 
 Another way of thinking about is: deriving clauses often infer constraints.
 For example:
@@ -864,10 +992,24 @@ kind parameters. Consider this code (also from Trac #11732):
 
     newtype Fun a b = Fun (a -> b) deriving (Cat k)
 
-Even though we requested an derived instance of the form (Cat k Fun), the
+Even though we requested a derived instance of the form (Cat k Fun), the
 kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
 the user wrote deriving (Cat *)).
 
+What happens with DerivingVia, when you have yet another type? Consider:
+
+  newtype Foo (a :: Type) = MkFoo (Proxy a)
+    deriving Functor via Proxy
+
+As before, we unify the kind of Foo (* -> *) with the kind of the argument to
+Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
+(k -> *), which is more general than what we want. So we must additionally
+unify (k -> *) with (* -> *).
+
+Currently, all of this unification is implemented kludgily with the pure
+unifier, which is rather tiresome. Trac #14331 lays out a plan for how this
+might be made cleaner.
+
 Note [Unification of two kind variables in deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 As a special case of the Note above, it is possible to derive an instance of
@@ -888,7 +1030,7 @@ the type variable binder for c, since its kind is (k2 -> k2 -> *).
 We used to accomplish this by doing the following:
 
     unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
-    (subst, _)    = mapAccumL substTyVarBndr kind_subst unmapped_tkvs
+    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
 
 Where all_tkvs contains all kind variables in the class and instance types (in
 this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
@@ -917,8 +1059,8 @@ mentions other type variables:
   data family Fam (f :: * -> *) (a :: *)
   newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
 
-With -XTypeInType, it is also possible to define kind synonyms, and they can
-mention other types in a datatype declaration. For example,
+It is also possible to define kind synonyms, and they can mention other types in
+a datatype declaration. For example,
 
   type Const a b = a
   newtype T f (a :: Const * f) = T (f a) deriving Functor
@@ -936,16 +1078,18 @@ mkEqnHelp :: Maybe OverlapMode
           -> [TyVar]
           -> Class -> [Type]
           -> TyCon -> [Type]
-          -> DerivContext       -- Just    => context supplied (standalone deriving)
-                                -- Nothing => context inferred (deriving on data decl)
-          -> Maybe DerivStrategy
+          -> DerivContext
+               -- SupplyContext => context supplied (standalone deriving)
+               -- InferContext  => context inferred (deriving on data decl, or
+               --                  standalone deriving decl with a wildcard)
+          -> Maybe (DerivStrategy GhcTc)
           -> TcRn EarlyDerivSpec
 -- Make the EarlyDerivSpec for an instance
 --      forall tvs. theta => cls (tys ++ [ty])
 -- where the 'theta' is optional (that's the Maybe part)
 -- Assumes that this declaration is well-kinded
 
-mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
   = do {      -- Find the instance of a data family
               -- Note [Looking up family instances for deriving]
          fam_envs <- tcGetFamInstEnvs
@@ -953,14 +1097,24 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta deriv_strat
               -- If it's still a data family, the lookup failed; i.e no instance exists
        ; when (isDataFamilyTyCon rep_tc)
               (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
-
-       ; dflags <- getDynFlags
-       ; if isDataTyCon rep_tc then
-            mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
-                          tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
-         else
-            mkNewTypeEqn dflags overlap_mode tvs cls cls_tys
-                         tycon tc_args rep_tc rep_tc_args mtheta deriv_strat }
+       ; is_boot <- tcIsHsBootOrSig
+       ; when is_boot $
+              bale_out (text "Cannot derive instances in hs-boot files"
+                    $+$ text "Write an instance declaration instead")
+
+       ; let deriv_env = DerivEnv
+                         { denv_overlap_mode = overlap_mode
+                         , denv_tvs          = tvs
+                         , denv_cls          = cls
+                         , denv_cls_tys      = cls_tys
+                         , denv_tc           = tycon
+                         , denv_tc_args      = tc_args
+                         , denv_rep_tc       = rep_tc
+                         , denv_rep_tc_args  = rep_tc_args
+                         , denv_ctxt         = deriv_ctxt
+                         , denv_strat        = deriv_strat }
+       ; flip runReaderT deriv_env $
+         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
   where
      bale_out msg = failWithTc (derivingThingErr False cls cls_tys
                       (mkTyConApp tycon tc_args) deriv_strat msg)
@@ -1031,59 +1185,48 @@ See Note [Eta reduction for data families] in FamInstEnv
 ************************************************************************
 -}
 
-mkDataTypeEqn :: DynFlags
-              -> Maybe OverlapMode
-              -> [TyVar]                -- Universally quantified type variables in the instance
-              -> Class                  -- Class for which we need to derive an instance
-              -> [Type]                 -- Other parameters to the class except the last
-              -> TyCon                  -- Type constructor for which the instance is requested
-                                        --    (last parameter to the type class)
-              -> [Type]                 -- Parameters to the type constructor
-              -> TyCon                  -- rep of the above (for type families)
-              -> [Type]                 -- rep of the above
-              -> DerivContext        -- Context of the instance, for standalone deriving
-              -> Maybe DerivStrategy    -- 'Just' if user requests a particular
-                                        -- deriving strategy.
-                                        -- Otherwise, 'Nothing'.
-              -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
-
-mkDataTypeEqn dflags overlap_mode tvs cls cls_tys
-              tycon tc_args rep_tc rep_tc_args mtheta deriv_strat
-  = case deriv_strat of
-      Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tc
-                                go_for_it bale_out
-      Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it bale_out
-      -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
-      Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
-      -- Lacking a user-requested deriving strategy, we will try to pick
-      -- between the stock or anyclass strategies
-      Nothing -> mk_eqn_no_mechanism dflags tycon mtheta cls cls_tys rep_tc
-                   go_for_it bale_out
-  where
-    go_for_it    = mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args
-                     rep_tc rep_tc_args mtheta (isJust deriv_strat)
-    bale_out msg = failWithTc (derivingThingErr False cls cls_tys
-                     (mkTyConApp tycon tc_args) deriv_strat msg)
-
-mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]
-            -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
-            -> Bool -- True if an explicit deriving strategy keyword was
-                    -- provided
-            -> DerivSpecMechanism -- How GHC should proceed attempting to
-                                  -- derive this instance, determined in
-                                  -- mkDataTypeEqn/mkNewTypeEqn
-            -> TcM EarlyDerivSpec
-mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
-            mtheta strat_used mechanism
-  = do doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tc mtheta
-                               strat_used mechanism
-       loc                  <- getSrcSpanM
-       dfun_name            <- newDFunName' cls tycon
-       case mtheta of
-        Nothing -> -- Infer context
+-- | Derive an instance for a data type (i.e., non-newtype).
+mkDataTypeEqn :: DerivM EarlyDerivSpec
+mkDataTypeEqn
+  = do mb_strat <- asks denv_strat
+       let bale_out msg = do err <- derivingThingErrM False msg
+                             lift $ failWithTc err
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just (ViaStrategy ty) -> mk_eqn_via ty
+         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
+         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
+         -- Lacking a user-requested deriving strategy, we will try to pick
+         -- between the stock or anyclass strategies
+         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out
+
+-- Derive an instance by way of an originative deriving strategy
+-- (stock or anyclass).
+--
+-- See Note [Deriving strategies]
+mk_originative_eqn
+  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or
+                        -- DerivSpecAnyclass
+  -> DerivM EarlyDerivSpec
+mk_originative_eqn mechanism
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       let inst_ty  = mkTyConApp tc tc_args
+           inst_tys = cls_tys ++ [inst_ty]
+       doDerivInstErrorChecks1 mechanism
+       loc       <- lift getSrcSpanM
+       dfun_name <- lift $ newDFunName' cls tc
+       case deriv_ctxt of
+        InferContext wildcard ->
           do { (inferred_constraints, tvs', inst_tys')
-                 <- inferConstraints tvs cls cls_tys inst_ty
-                                     rep_tc rep_tc_args mechanism
+                 <- inferConstraints mechanism
              ; return $ InferTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs'
@@ -1091,9 +1234,10 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
                    , ds_tc = rep_tc
                    , ds_theta = inferred_constraints
                    , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = wildcard
                    , ds_mechanism = mechanism } }
 
-        Just theta -> do -- Specified context
+        SupplyContext theta ->
             return $ GivenTheta $ DS
                    { ds_loc = loc
                    , ds_name = dfun_name, ds_tvs = tvs
@@ -1101,306 +1245,387 @@ mk_data_eqn overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args
                    , ds_tc = rep_tc
                    , ds_theta = theta
                    , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = Nothing
                    , ds_mechanism = mechanism }
-  where
-    inst_ty  = mkTyConApp tycon tc_args
-    inst_tys = cls_tys ++ [inst_ty]
-
-mk_eqn_stock :: DynFlags -> DerivContext -> Class -> [Type] -> TyCon
-             -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-             -> (SDoc -> TcRn EarlyDerivSpec)
-             -> TcRn EarlyDerivSpec
-mk_eqn_stock dflags mtheta cls cls_tys rep_tc go_for_it bale_out
-  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
-        CanDerive               -> mk_eqn_stock' cls go_for_it
-        DerivableClassError msg -> bale_out msg
-        _                       -> bale_out (nonStdErr cls)
-
-mk_eqn_stock' :: Class -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-                -> TcRn EarlyDerivSpec
-mk_eqn_stock' cls go_for_it
-  = go_for_it $ case hasStockDeriving cls of
-        Just gen_fn -> DerivSpecStock gen_fn
-        Nothing ->
-          pprPanic "mk_eqn_stock': Not a stock class!" (ppr cls)
-
-mk_eqn_anyclass :: DynFlags
-                -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-                -> (SDoc -> TcRn EarlyDerivSpec)
-                -> TcRn EarlyDerivSpec
-mk_eqn_anyclass dflags go_for_it bale_out
-  = case canDeriveAnyClass dflags of
-        IsValid      -> go_for_it DerivSpecAnyClass
-        NotValid msg -> bale_out msg
-
-mk_eqn_no_mechanism :: DynFlags -> TyCon -> DerivContext
-                    -> Class -> [Type] -> TyCon
-                    -> (DerivSpecMechanism -> TcRn EarlyDerivSpec)
-                    -> (SDoc -> TcRn EarlyDerivSpec)
-                    -> TcRn EarlyDerivSpec
-mk_eqn_no_mechanism dflags tc mtheta cls cls_tys rep_tc go_for_it bale_out
-  = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
-        -- NB: pass the *representation* tycon to checkSideConditions
-        NonDerivableClass   msg -> bale_out (dac_error msg)
-        DerivableClassError msg -> bale_out msg
-        CanDerive               -> mk_eqn_stock' cls go_for_it
-        DerivableViaInstance    -> go_for_it DerivSpecAnyClass
-  where
-    -- See Note [Deriving instances for classes themselves]
-    dac_error msg
-      | isClassTyCon rep_tc
-      = quotes (ppr tc) <+> text "is a type class,"
-                        <+> text "and can only have a derived instance"
-                        $+$ text "if DeriveAnyClass is enabled"
-      | otherwise
-      = nonStdErr cls $$ msg
 
-{-
-************************************************************************
-*                                                                      *
-                Deriving newtypes
-*                                                                      *
-************************************************************************
--}
-
-mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [TyVar] -> Class
-             -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
-             -> DerivContext -> Maybe DerivStrategy
-             -> TcRn EarlyDerivSpec
-mkNewTypeEqn dflags overlap_mode tvs
-             cls cls_tys tycon tc_args rep_tycon rep_tc_args
-             mtheta deriv_strat
--- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
-  = ASSERT( cls_tys `lengthIs` (classArity cls - 1) )
-    case deriv_strat of
-      Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon
-                                 go_for_it_other bale_out
-      Just AnyclassStrategy -> mk_eqn_anyclass dflags go_for_it_other bale_out
-      Just NewtypeStrategy  ->
-        -- Since the user explicitly asked for GeneralizedNewtypeDeriving, we
-        -- don't need to perform all of the checks we normally would, such as
-        -- if the class being derived is known to produce ill-roled coercions
-        -- (e.g., Traversable), since we can just derive the instance and let
-        -- it error if need be.
-        -- See Note [Determining whether newtype-deriving is appropriate]
-        if coercion_looks_sensible && newtype_deriving
-          then go_for_it_gnd
-          else bale_out (cant_derive_err $$
-                         if newtype_deriving then empty else suggest_gnd)
-      Nothing
-        | might_derive_via_coercible
-          && ((newtype_deriving && not deriveAnyClass)
-               || std_class_via_coercible cls)
-       -> go_for_it_gnd
-        | otherwise
-       -> case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
-            DerivableClassError msg
-              -- There's a particular corner case where
-              --
-              -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are both
-              --    enabled at the same time
-              -- 2. We're deriving a particular stock derivable class
-              --    (such as Functor)
-              --
-              -- and the previous cases won't catch it. This fixes the bug
-              -- reported in Trac #10598.
-              | might_derive_via_coercible && newtype_deriving
-             -> go_for_it_gnd
-              -- Otherwise, throw an error for a stock class
-              | might_derive_via_coercible && not newtype_deriving
-             -> bale_out (msg $$ suggest_gnd)
-              | otherwise
-             -> bale_out msg
-
-            -- Must use newtype deriving or DeriveAnyClass
-            NonDerivableClass _msg
-              -- Too hard, even with newtype deriving
-              | newtype_deriving           -> bale_out cant_derive_err
-              -- Try newtype deriving!
-              -- Here we suggest GeneralizedNewtypeDeriving even in cases where
-              -- it may not be applicable. See Trac #9600.
-              | otherwise                  -> bale_out (non_std $$ suggest_gnd)
-
-            -- DerivableViaInstance
-            DerivableViaInstance -> do
-              -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
-              -- enabled, we take the diplomatic approach of defaulting to
-              -- DeriveAnyClass, but emitting a warning about the choice.
-              -- See Note [Deriving strategies]
-              when (newtype_deriving && deriveAnyClass) $
-                addWarnTc NoReason $ sep
-                  [ text "Both DeriveAnyClass and"
-                    <+> text "GeneralizedNewtypeDeriving are enabled"
-                  , text "Defaulting to the DeriveAnyClass strategy"
-                    <+> text "for instantiating" <+> ppr cls ]
-              go_for_it_other DerivSpecAnyClass
-            -- CanDerive
-            CanDerive -> mk_eqn_stock' cls go_for_it_other
-  where
-        newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
-        deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
-        go_for_it_gnd     = do
-          traceTc "newtype deriving:" $
-            ppr tycon <+> ppr rep_tys <+> ppr all_thetas
-          let mechanism = DerivSpecNewtype rep_inst_ty
-          doDerivInstErrorChecks1 cls cls_tys tycon tc_args rep_tycon mtheta
-                                  strat_used mechanism
-          dfun_name <- newDFunName' cls tycon
-          loc <- getSrcSpanM
-          case mtheta of
-           Just theta -> return $ GivenTheta $ DS
-               { ds_loc = loc
-               , ds_name = dfun_name, ds_tvs = tvs
-               , ds_cls = cls, ds_tys = inst_tys
-               , ds_tc = rep_tycon
-               , ds_theta = theta
-               , ds_overlap = overlap_mode
-               , ds_mechanism = mechanism }
-           Nothing -> return $ InferTheta $ DS
-               { ds_loc = loc
-               , ds_name = dfun_name, ds_tvs = tvs
-               , ds_cls = cls, ds_tys = inst_tys
-               , ds_tc = rep_tycon
-               , ds_theta = all_thetas
-               , ds_overlap = overlap_mode
-               , ds_mechanism = mechanism }
-        go_for_it_other = mk_data_eqn overlap_mode tvs cls cls_tys tycon
-                            tc_args rep_tycon rep_tc_args mtheta strat_used
-        bale_out    = bale_out' newtype_deriving
-        bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty
-                                                    deriv_strat
-
-        strat_used  = isJust deriv_strat
-        non_std     = nonStdErr cls
-        suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension"
-
-        -- Here is the plan for newtype derivings.  We see
-        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
-        -- where t is a type,
-        --       ak+1...an is a suffix of a1..an, and are all tyvars
-        --       ak+1...an do not occur free in t, nor in the s1..sm
-        --       (C s1 ... sm) is a  *partial applications* of class C
-        --                      with the last parameter missing
-        --       (T a1 .. ak) matches the kind of C's last argument
-        --              (and hence so does t)
-        -- The latter kind-check has been done by deriveTyData already,
-        -- and tc_args are already trimmed
-        --
-        -- We generate the instance
-        --       instance forall ({a1..ak} u fvs(s1..sm)).
-        --                C s1 .. sm t => C s1 .. sm (T a1...ak)
-        -- where T a1...ap is the partial application of
-        --       the LHS of the correct kind and p >= k
-        --
-        --      NB: the variables below are:
-        --              tc_tvs = [a1, ..., an]
-        --              tyvars_to_keep = [a1, ..., ak]
-        --              rep_ty = t ak .. an
-        --              deriv_tvs = fvs(s1..sm) \ tc_tvs
-        --              tys = [s1, ..., sm]
-        --              rep_fn' = t
-        --
-        -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
-        -- We generate the instance
-        --      instance Monad (ST s) => Monad (T s) where
-
-        nt_eta_arity = newTyConEtadArity rep_tycon
-                -- For newtype T a b = MkT (S a a b), the TyCon machinery already
-                -- eta-reduces the representation type, so we know that
-                --      T a ~ S a a
-                -- That's convenient here, because we may have to apply
-                -- it to fewer than its original complement of arguments
-
-        -- Note [Newtype representation]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- Need newTyConRhs (*not* a recursive representation finder)
-        -- to get the representation type. For example
-        --      newtype B = MkB Int
-        --      newtype A = MkA B deriving( Num )
-        -- We want the Num instance of B, *not* the Num instance of Int,
-        -- when making the Num instance of A!
-        rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
-        rep_tys     = cls_tys ++ [rep_inst_ty]
-        rep_pred    = mkClassPred cls rep_tys
-        rep_pred_o  = mkPredOrigin DerivOrigin TypeLevel rep_pred
-                -- rep_pred is the representation dictionary, from where
-                -- we are gong to get all the methods for the newtype
-                -- dictionary
-
-        -- Next we figure out what superclass dictionaries to use
-        -- See Note [Newtype deriving superclasses] above
-        sc_preds   :: [PredOrigin]
-        cls_tyvars = classTyVars cls
-        inst_ty    = mkTyConApp tycon tc_args
-        inst_tys   = cls_tys ++ [inst_ty]
-        sc_preds   = map (mkPredOrigin DerivOrigin TypeLevel) $
-                     substTheta (zipTvSubst cls_tyvars inst_tys) $
-                     classSCTheta cls
-
-        -- Next we collect constraints for the class methods
-        -- If there are no methods, we don't need any constraints
-        -- Otherwise we need (C rep_ty), for the representation methods,
-        -- and constraints to coerce each individual method
-        meth_preds :: [PredOrigin]
-        meths = classMethods cls
-        meth_preds | null meths = [] -- No methods => no constraints
-                                     -- (Trac #12814)
-                   | otherwise = rep_pred_o : coercible_constraints
-        coercible_constraints
-          = [ mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
-                           (mkReprPrimEqPred t1 t2)
-            | meth <- meths
-            , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
-                                         inst_tys rep_inst_ty meth ]
-
-        all_thetas :: [ThetaOrigin]
-        all_thetas = [mkThetaOriginFromPreds $ meth_preds ++ sc_preds]
-
-        -------------------------------------------------------------------
-        --  Figuring out whether we can only do this newtype-deriving thing
-
-        -- See Note [Determining whether newtype-deriving is appropriate]
-        might_derive_via_coercible
-           =  not (non_coercible_class cls)
-           && coercion_looks_sensible
---         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
-        coercion_looks_sensible
-           =  eta_ok
-              -- Check (a) from Note [GND and associated type families]
-           && ats_ok
+-- Derive an instance by way of a coerce-based deriving strategy
+-- (newtype or via).
+--
+-- See Note [Deriving strategies]
+mk_coerce_based_eqn
+  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype
+                                  -- or DerivSpecVia
+  -> Type -- The type to coerce
+  -> DerivM EarlyDerivSpec
+mk_coerce_based_eqn mk_mechanism coerced_ty
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tycon
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tycon
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       sa_wildcard <- isStandaloneWildcardDeriv
+       let -- The following functions are polymorphic over the representation
+           -- type, since we might either give it the underlying type of a
+           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
+           -- (for DerivingVia).
+           rep_tys ty  = cls_tys ++ [ty]
+           rep_pred ty = mkClassPred cls (rep_tys ty)
+           rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)
+                   -- rep_pred is the representation dictionary, from where
+                   -- we are going to get all the methods for the final
+                   -- dictionary
+
+           -- Next we figure out what superclass dictionaries to use
+           -- See Note [Newtype deriving superclasses] above
+           sc_preds   :: [PredOrigin]
+           cls_tyvars = classTyVars cls
+           inst_ty    = mkTyConApp tycon tc_args
+           inst_tys   = cls_tys ++ [inst_ty]
+           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $
+                        substTheta (zipTvSubst cls_tyvars inst_tys) $
+                        classSCTheta cls
+           deriv_origin = mkDerivOrigin sa_wildcard
+
+           -- Next we collect constraints for the class methods
+           -- If there are no methods, we don't need any constraints
+           -- Otherwise we need (C rep_ty), for the representation methods,
+           -- and constraints to coerce each individual method
+           meth_preds :: Type -> [PredOrigin]
+           meths = classMethods cls
+           meth_preds ty
+             | null meths = [] -- No methods => no constraints
+                               -- (Trac #12814)
+             | otherwise = rep_pred_o ty : coercible_constraints ty
+           coercible_constraints ty
+             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+                              TypeLevel (mkReprPrimEqPred t1 t2)
+               | meth <- meths
+               , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
+                                            inst_tys ty meth ]
+
+           all_thetas :: Type -> [ThetaOrigin]
+           all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]
+
+           inferred_thetas = all_thetas coerced_ty
+       lift $ traceTc "newtype deriving:" $
+         ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
+       let mechanism = mk_mechanism coerced_ty
+           bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                             lift $ failWithTc err
+       atf_coerce_based_error_checks cls bale_out
+       doDerivInstErrorChecks1 mechanism
+       dfun_name <- lift $ newDFunName' cls tycon
+       loc       <- lift getSrcSpanM
+       case deriv_ctxt of
+        SupplyContext theta -> return $ GivenTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = theta
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = Nothing
+            , ds_mechanism = mechanism }
+        InferContext wildcard -> return $ InferTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = inferred_thetas
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = wildcard
+            , ds_mechanism = mechanism }
+
+-- Ensure that a class's associated type variables are suitable for
+-- GeneralizedNewtypeDeriving or DerivingVia.
+--
+-- See Note [GND and associated type families]
+atf_coerce_based_error_checks
+  :: Class
+  -> (SDoc -> DerivM ())
+  -> DerivM ()
+atf_coerce_based_error_checks cls bale_out
+  = let cls_tyvars = classTyVars cls
+
+        ats_look_sensible
+           =  -- Check (a) from Note [GND and associated type families]
+              no_adfs
               -- Check (b) from Note [GND and associated type families]
            && isNothing at_without_last_cls_tv
-
-        -- Check that eta reduction is OK
-        eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
-                -- The newtype can be eta-reduced to match the number
-                --     of type argument actually supplied
-                --        newtype T a b = MkT (S [a] b) deriving( Monad )
-                --     Here the 'b' must be the same in the rep type (S [a] b)
-                --     And the [a] must not mention 'b'.  That's all handled
-                --     by nt_eta_rity.
+              -- Check (d) from Note [GND and associated type families]
+           && isNothing at_last_cls_tv_in_kinds
 
         (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
-        ats_ok             = null adf_tcs
+        no_adfs            = null adf_tcs
                -- We cannot newtype-derive data family instances
 
         at_without_last_cls_tv
           = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
+        at_last_cls_tv_in_kinds
+          = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
+                             (tyConTyVars tc)
+                      || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
+        at_last_cls_tv_in_kind kind
+          = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
         at_tcs = classATs cls
         last_cls_tv = ASSERT( notNull cls_tyvars )
                       last cls_tyvars
 
         cant_derive_err
-           = vcat [ ppUnless eta_ok eta_msg
-                  , ppUnless ats_ok ats_msg
-                  , maybe empty at_tv_msg
-                          at_without_last_cls_tv]
-        eta_msg   = text "cannot eta-reduce the representation type enough"
-        ats_msg   = text "the class has associated data types"
-        at_tv_msg at_tc = hang
+           = vcat [ ppUnless no_adfs adfs_msg
+                  , maybe empty at_without_last_cls_tv_msg
+                          at_without_last_cls_tv
+                  , maybe empty at_last_cls_tv_in_kinds_msg
+                          at_last_cls_tv_in_kinds
+                  ]
+        adfs_msg  = text "the class has associated data types"
+        at_without_last_cls_tv_msg at_tc = hang
           (text "the associated type" <+> quotes (ppr at_tc)
            <+> text "is not parameterized over the last type variable")
           2 (text "of the class" <+> quotes (ppr cls))
+        at_last_cls_tv_in_kinds_msg at_tc = hang
+          (text "the associated type" <+> quotes (ppr at_tc)
+           <+> text "contains the last type variable")
+         2 (text "of the class" <+> quotes (ppr cls)
+           <+> text "in a kind, which is not (yet) allowed")
+    in unless ats_look_sensible $ bale_out cant_derive_err
+
+mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+             -> (SDoc -> DerivM EarlyDerivSpec)
+             -> DerivM EarlyDerivSpec
+mk_eqn_stock go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
+         StockClassError msg   -> bale_out msg
+         _                     -> bale_out (nonStdErr cls)
+
+mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                -> (SDoc -> DerivM EarlyDerivSpec)
+                -> DerivM EarlyDerivSpec
+mk_eqn_anyclass go_for_it bale_out
+  = do dflags <- getDynFlags
+       case canDeriveAnyClass dflags of
+         IsValid      -> go_for_it DerivSpecAnyClass
+         NotValid msg -> bale_out msg
+
+mk_eqn_newtype :: Type -- The newtype's representation type
+               -> DerivM EarlyDerivSpec
+mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype
+
+mk_eqn_via :: Type -- The @via@ type
+           -> DerivM EarlyDerivSpec
+mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
+
+mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                    -> (SDoc -> DerivM EarlyDerivSpec)
+                    -> DerivM EarlyDerivSpec
+mk_eqn_no_mechanism go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+
+           -- See Note [Deriving instances for classes themselves]
+       let dac_error msg
+             | isClassTyCon rep_tc
+             = quotes (ppr tc) <+> text "is a type class,"
+                               <+> text "and can only have a derived instance"
+                               $+$ text "if DeriveAnyClass is enabled"
+             | otherwise
+             = nonStdErr cls $$ msg
+
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+           -- NB: pass the *representation* tycon to
+           -- checkOriginativeSideConditions
+           NonDerivableClass   msg -> bale_out (dac_error msg)
+           StockClassError msg     -> bale_out msg
+           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn
+           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass
+
+{-
+************************************************************************
+*                                                                      *
+            GeneralizedNewtypeDeriving and DerivingVia
+*                                                                      *
+************************************************************************
+-}
+
+-- | Derive an instance for a newtype.
+mkNewTypeEqn :: DerivM EarlyDerivSpec
+mkNewTypeEqn
+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
+  = do DerivEnv { denv_tc           = tycon
+                , denv_rep_tc       = rep_tycon
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt
+                , denv_strat        = mb_strat } <- ask
+       dflags <- getDynFlags
+
+       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
+           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
+           bale_out        = bale_out' newtype_deriving
+           bale_out' b msg = do err <- derivingThingErrM b msg
+                                lift $ failWithTc err
+
+           non_std     = nonStdErr cls
+           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
+                     <+> text "newtype-deriving extension"
+
+           -- Here is the plan for newtype derivings.  We see
+           --        newtype T a1...an = MkT (t ak+1...an)
+           --          deriving (.., C s1 .. sm, ...)
+           -- where t is a type,
+           --       ak+1...an is a suffix of a1..an, and are all tyvars
+           --       ak+1...an do not occur free in t, nor in the s1..sm
+           --       (C s1 ... sm) is a  *partial applications* of class C
+           --                      with the last parameter missing
+           --       (T a1 .. ak) matches the kind of C's last argument
+           --              (and hence so does t)
+           -- The latter kind-check has been done by deriveTyData already,
+           -- and tc_args are already trimmed
+           --
+           -- We generate the instance
+           --       instance forall ({a1..ak} u fvs(s1..sm)).
+           --                C s1 .. sm t => C s1 .. sm (T a1...ak)
+           -- where T a1...ap is the partial application of
+           --       the LHS of the correct kind and p >= k
+           --
+           --      NB: the variables below are:
+           --              tc_tvs = [a1, ..., an]
+           --              tyvars_to_keep = [a1, ..., ak]
+           --              rep_ty = t ak .. an
+           --              deriv_tvs = fvs(s1..sm) \ tc_tvs
+           --              tys = [s1, ..., sm]
+           --              rep_fn' = t
+           --
+           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+           -- We generate the instance
+           --      instance Monad (ST s) => Monad (T s) where
+
+           nt_eta_arity = newTyConEtadArity rep_tycon
+                   -- For newtype T a b = MkT (S a a b), the TyCon
+                   -- machinery already eta-reduces the representation type, so
+                   -- we know that
+                   --      T a ~ S a a
+                   -- That's convenient here, because we may have to apply
+                   -- it to fewer than its original complement of arguments
+
+           -- Note [Newtype representation]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Need newTyConRhs (*not* a recursive representation finder)
+           -- to get the representation type. For example
+           --      newtype B = MkB Int
+           --      newtype A = MkA B deriving( Num )
+           -- We want the Num instance of B, *not* the Num instance of Int,
+           -- when making the Num instance of A!
+           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
+
+           -------------------------------------------------------------------
+           --  Figuring out whether we can only do this newtype-deriving thing
+
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           might_be_newtype_derivable
+              =  not (non_coercible_class cls)
+              && eta_ok
+--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
+
+           -- Check that eta reduction is OK
+           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
+             -- The newtype can be eta-reduced to match the number
+             --     of type argument actually supplied
+             --        newtype T a b = MkT (S [a] b) deriving( Monad )
+             --     Here the 'b' must be the same in the rep type (S [a] b)
+             --     And the [a] must not mention 'b'.  That's all handled
+             --     by nt_eta_rity.
+
+           cant_derive_err = ppUnless eta_ok  eta_msg
+           eta_msg = text "cannot eta-reduce the representation type enough"
+
+       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just NewtypeStrategy  ->
+           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
+           -- we don't need to perform all of the checks we normally would,
+           -- such as if the class being derived is known to produce ill-roled
+           -- coercions (e.g., Traversable), since we can just derive the
+           -- instance and let it error if need be.
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           if eta_ok && newtype_deriving
+             then mk_eqn_newtype rep_inst_ty
+             else bale_out (cant_derive_err $$
+                            if newtype_deriving then empty else suggest_gnd)
+         Just (ViaStrategy via_ty) ->
+           -- NB: For DerivingVia, we don't need to any eta-reduction checking,
+           -- since the @via@ type is already "eta-reduced".
+           mk_eqn_via via_ty
+         Nothing
+           | might_be_newtype_derivable
+             && ((newtype_deriving && not deriveAnyClass)
+                  || std_class_via_coercible cls)
+          -> mk_eqn_newtype rep_inst_ty
+           | otherwise
+          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                                 tycon rep_tycon of
+               StockClassError msg
+                 -- There's a particular corner case where
+                 --
+                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
+                 --    both enabled at the same time
+                 -- 2. We're deriving a particular stock derivable class
+                 --    (such as Functor)
+                 --
+                 -- and the previous cases won't catch it. This fixes the bug
+                 -- reported in Trac #10598.
+                 | might_be_newtype_derivable && newtype_deriving
+                -> mk_eqn_newtype rep_inst_ty
+                 -- Otherwise, throw an error for a stock class
+                 | might_be_newtype_derivable && not newtype_deriving
+                -> bale_out (msg $$ suggest_gnd)
+                 | otherwise
+                -> bale_out msg
+
+               -- Must use newtype deriving or DeriveAnyClass
+               NonDerivableClass _msg
+                 -- Too hard, even with newtype deriving
+                 | newtype_deriving           -> bale_out cant_derive_err
+                 -- Try newtype deriving!
+                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
+                 -- where it may not be applicable. See Trac #9600.
+                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)
+
+               -- DeriveAnyClass
+               CanDeriveAnyClass -> do
+                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
+                 -- enabled, we take the diplomatic approach of defaulting to
+                 -- DeriveAnyClass, but emitting a warning about the choice.
+                 -- See Note [Deriving strategies]
+                 when (newtype_deriving && deriveAnyClass) $
+                   lift $ addWarnTc NoReason $ sep
+                     [ text "Both DeriveAnyClass and"
+                       <+> text "GeneralizedNewtypeDeriving are enabled"
+                     , text "Defaulting to the DeriveAnyClass strategy"
+                       <+> text "for instantiating" <+> ppr cls ]
+                 mk_originative_eqn DerivSpecAnyClass
+               -- CanDeriveStock
+               CanDeriveStock gen_fn -> mk_originative_eqn $
+                                        DerivSpecStock gen_fn
 
 {-
 Note [Recursive newtypes]
@@ -1521,6 +1746,29 @@ However, we must watch out for three things:
     GHC's termination checker isn't sophisticated enough to conclude that the
     definition of T MyInt terminates, so UndecidableInstances is required.
 
+(d) For the time being, we do not allow the last type variable of the class to
+    appear in a /kind/ of an associated type family definition. For instance:
+
+    class C a where
+      type T1 a        -- OK
+      type T2 (x :: a) -- Illegal: a appears in the kind of x
+      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)
+
+    The reason we disallow this is because our current approach to deriving
+    associated type family instances—i.e., by unwrapping the newtype's type
+    constructor as shown above—is ill-equipped to handle the scenario when
+    the last type variable appears as an implicit argument. In the worst case,
+    allowing the last variable to appear in a kind can result in improper Core
+    being generated (see #14728).
+
+    There is hope for this feature being added some day, as one could
+    conceivably take a newtype axiom (which witnesses a coercion between a
+    newtype and its representation type) at lift that through each associated
+    type at the Core level. See #14728, comment:3 for a sketch of how this
+    might work. Until then, we disallow this featurette wholesale.
+
+The same criteria apply to DerivingVia.
+
 ************************************************************************
 *                                                                      *
 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
@@ -1598,12 +1846,14 @@ genInst :: DerivSpec theta
 -- See Note [Staging of tcDeriving]
 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_mechanism = mechanism, ds_tys = tys
-                 , ds_cls = clas, ds_loc = loc })
+                 , ds_cls = clas, ds_loc = loc
+                 , ds_standalone_wildcard = wildcard })
   = do (meth_binds, deriv_stuff, unusedNames)
-         <- genDerivStuff mechanism loc clas rep_tycon tys tvs
-       let mk_inst_info theta = do
+         <- set_span_and_ctxt $
+            genDerivStuff mechanism loc clas rep_tycon tys tvs
+       let mk_inst_info theta = set_span_and_ctxt $ do
              inst_spec <- newDerivClsInst theta spec
-             doDerivInstErrorChecks2 clas inst_spec mechanism
+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
              traceTc "newder" (ppr inst_spec)
              return $ InstInfo
                        { iSpec   = inst_spec
@@ -1617,43 +1867,64 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
   where
     extensions :: [LangExt.Extension]
     extensions
-      | isDerivSpecNewtype mechanism
+      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
         -- Both these flags are needed for higher-rank uses of coerce
         -- See Note [Newtype-deriving instances] in TcGenDeriv
       = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
       | otherwise
       = []
 
-doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon
-                        -> DerivContext -> Bool -> DerivSpecMechanism
-                        -> TcM ()
-doDerivInstErrorChecks1 cls cls_tys tc tc_args rep_tc mtheta
-                        strat_used mechanism = do
-    -- For standalone deriving (mtheta /= Nothing),
-    -- check that all the data constructors are in scope...
-    rdr_env <- getGlobalRdrEnv
+    set_span_and_ctxt :: TcM a -> TcM a
+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
+
+doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
+doDerivInstErrorChecks1 mechanism = do
+    DerivEnv { denv_tc      = tc
+             , denv_rep_tc  = rep_tc } <- ask
+    standalone <- isStandaloneDeriv
+    let anyclass_strategy = isDerivSpecAnyClass mechanism
+        via_strategy      = isDerivSpecVia mechanism
+        bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                          lift $ failWithTc err
+
+    -- For standalone deriving, check that all the data constructors are in
+    -- scope...
+    rdr_env <- lift getGlobalRdrEnv
     let data_con_names = map dataConName (tyConDataCons rep_tc)
         hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
                            (isAbstractTyCon rep_tc ||
                             any not_in_scope data_con_names)
         not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
 
-    addUsedDataCons rdr_env rep_tc
+    lift $ addUsedDataCons rdr_env rep_tc
+
     -- ...however, we don't perform this check if we're using DeriveAnyClass,
     -- since it doesn't generate any code that requires use of a data
-    -- constructor.
-    unless (anyclass_strategy || isNothing mtheta || not hidden_data_cons) $
+    -- constructor. Nor do we perform this check with @deriving via@, as it
+    -- doesn't explicitly require the constructors to be in scope.
+    unless (anyclass_strategy || via_strategy
+            || not standalone || not hidden_data_cons) $
            bale_out $ derivingHiddenErr tc
-  where
-    anyclass_strategy = isDerivSpecAnyClass mechanism
-
-    bale_out msg = failWithTc (derivingThingErrMechanism cls cls_tys
-                     (mkTyConApp tc tc_args) strat_used mechanism msg)
 
-doDerivInstErrorChecks2 :: Class -> ClsInst -> DerivSpecMechanism -> TcM ()
-doDerivInstErrorChecks2 clas clas_inst mechanism
+doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
+                        -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
   = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
        ; dflags <- getDynFlags
+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
+
+         -- Error if PartialTypeSignatures isn't enabled when a user tries
+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
+         -- extension is enabled, give a warning if -Wpartial-type-signatures
+         -- is enabled.
+       ; case wildcard of
+           Nothing -> pure ()
+           Just span -> setSrcSpan span $ do
+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)
+             warnTc (Reason Opt_WarnPartialTypeSignatures)
+                    wpartial_sigs partial_sig_msg
+
          -- Check for Generic instances that are derived with an exotic
          -- deriving strategy like DAC
          -- See Note [Deriving strategies]
@@ -1661,14 +1932,16 @@ doDerivInstErrorChecks2 clas clas_inst mechanism
          do { failIfTc (safeLanguageOn dflags) gen_inst_err
             ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
   where
-    exotic_mechanism = case mechanism of
-      DerivSpecStock{} -> False
-      _                -> True
+    exotic_mechanism = not $ isDerivSpecStock mechanism
+
+    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')
+                  <+> text "standing for" <+> quotes (pprTheta theta)
+
+    pts_suggestion
+      = text "To use the inferred type, enable PartialTypeSignatures"
 
-    gen_inst_err = hang (text ("Generic instances can only be derived in "
-                            ++ "Safe Haskell using the stock strategy.") $+$
-                         text "In the following instance:")
-                      2 (pprInstanceHdr clas_inst)
+    gen_inst_err = text "Generic instances can only be derived in"
+               <+> text "Safe Haskell using the stock strategy."
 
 genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
               -> TyCon -> [Type] -> [TyVar]
@@ -1676,15 +1949,12 @@ genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
 genDerivStuff mechanism loc clas tycon inst_tys tyvars
   = case mechanism of
       -- See Note [Bindings for Generalised Newtype Deriving]
-      DerivSpecNewtype rhs_ty -> do
-        (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys rhs_ty
-        return (binds, faminsts, maybeToList unusedConName)
+      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty
 
       -- Try a stock deriver
       DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
 
-      -- If there isn't a stock deriver, our last resort is -XDeriveAnyClass
-      -- (since -XGeneralizedNewtypeDeriving fell through).
+      -- Try DeriveAnyClass
       DerivSpecAnyClass -> do
         let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
             mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
@@ -1694,7 +1964,7 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars
           -- unless -XDeriveAnyClass is enabled.
           ASSERT2( isValid (canDeriveAnyClass dflags)
                  , ppr "genDerivStuff: bad derived class" <+> ppr clas )
-          mapM (tcATDefault False loc mini_subst emptyNameSet)
+          mapM (tcATDefault loc mini_subst emptyNameSet)
                (classATItems clas)
         return ( emptyBag -- No method bindings are needed...
                , listToBag (map DerivFamInst (concat tyfam_insts))
@@ -1702,7 +1972,14 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars
                -- family default instances.
                -- See Note [DeriveAnyClass and default family instances]
                , [] )
+
+      -- Try DerivingVia
+      DerivSpecVia via_ty -> gen_newtype_or_via via_ty
   where
+    gen_newtype_or_via ty = do
+      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
+      return (binds, faminsts, maybeToList unusedConName)
+
     unusedConName :: Maybe Name
     unusedConName
       | isDerivSpecNewtype mechanism
@@ -1755,8 +2032,8 @@ is used:
 In the latter case, we must take care to check if C has any associated type
 families with default instances, because -XDeriveAnyClass will never provide
 an implementation for them. We "fill in" the default instances using the
-tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
-the empty instance declaration case).
+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to
+handle the empty instance declaration case).
 
 Note [Deriving strategies]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1794,6 +2071,14 @@ Currently, the deriving strategies are:
 
 * newtype: Use -XGeneralizedNewtypeDeriving
 
+* via: Use -XDerivingVia
+
+The latter two strategies (newtype and via) are referred to as the
+"coerce-based" strategies, since they generate code that relies on the `coerce`
+function. The former two strategies (stock and anyclass), in contrast, are
+referred to as the "originative" strategies, since they create "original"
+instances instead of "reusing" old instances (by way of `coerce`).
+
 If an explicit deriving strategy is not given, GHC has an algorithm it uses to
 determine which strategy it will actually use. The algorithm is quite long,
 so it lives in the Haskell wiki at
@@ -1863,39 +2148,62 @@ derivingKindErr tc cls cls_tys cls_kind enough_args
                     = text "(Perhaps you intended to use PolyKinds)"
                     | otherwise = Outputable.empty
 
+derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc
+derivingViaKindErr cls cls_kind via_ty via_kind
+  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))
+       2 (text "Class" <+> quotes (ppr cls)
+               <+> text "expects an argument of kind"
+               <+> quotes (pprKind cls_kind) <> char ','
+      $+$ text "but" <+> quotes (pprType via_ty)
+               <+> text "has kind" <+> quotes (pprKind via_kind))
+
 derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
 derivingEtaErr cls cls_tys inst_ty
   = sep [text "Cannot eta-reduce to an instance of form",
          nest 2 (text "instance (...) =>"
                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
 
-derivingThingErr :: Bool -> Class -> [Type] -> Type -> Maybe DerivStrategy
-                 -> MsgDoc -> MsgDoc
-derivingThingErr newtype_deriving clas tys ty deriv_strat why
-  = derivingThingErr' newtype_deriving clas tys ty (isJust deriv_strat)
-                      (maybe empty ppr deriv_strat) why
-
-derivingThingErrMechanism :: Class -> [Type] -> Type
-                          -> Bool -- True if an explicit deriving strategy
-                                  -- keyword was provided
-                          -> DerivSpecMechanism
-                          -> MsgDoc -> MsgDoc
-derivingThingErrMechanism clas tys ty strat_used mechanism why
-  = derivingThingErr' (isDerivSpecNewtype mechanism) clas tys ty strat_used
-                      (ppr mechanism) why
-
-derivingThingErr' :: Bool -> Class -> [Type] -> Type -> Bool -> MsgDoc
-                  -> MsgDoc -> MsgDoc
-derivingThingErr' newtype_deriving clas tys ty strat_used strat_msg why
+derivingThingErr :: Bool -> Class -> [Type] -> Type
+                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
+derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why
+  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat
+                      (maybe empty derivStrategyName mb_strat) why
+
+derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
+derivingThingErrM newtype_deriving why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr newtype_deriving cls cls_tys
+                               (mkTyConApp tc tc_args) mb_strat why
+
+derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
+derivingThingErrMechanism mechanism why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys
+                (mkTyConApp tc tc_args) mb_strat
+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)
+                why
+
+derivingThingErr' :: Bool -> Class -> [Type] -> Type
+                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
+derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
   = sep [(hang (text "Can't make a derived instance of")
              2 (quotes (ppr pred) <+> via_mechanism)
           $$ nest 2 extra) <> colon,
          nest 2 why]
   where
+    strat_used = isJust mb_strat
     extra | not strat_used, newtype_deriving
           = text "(even with cunning GeneralizedNewtypeDeriving)"
           | otherwise = empty
-    pred = mkClassPred clas (tys ++ [ty])
+    pred = mkClassPred cls (cls_tys ++ [inst_ty])
     via_mechanism | strat_used
                   = text "with the" <+> strat_msg <+> text "strategy"
                   | otherwise
@@ -1906,10 +2214,6 @@ derivingHiddenErr tc
   = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
        2 (text "so you cannot derive an instance for it")
 
-standaloneCtxt :: LHsSigType GhcRn -> SDoc
+standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
 standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
                        2 (quotes (ppr ty))
-
-unboxedTyConErr :: String -> MsgDoc
-unboxedTyConErr thing =
-  text "The last argument of the instance cannot be an unboxed" <+> text thing
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
index 02c0103eec..3f4192fb42 100644
--- a/compiler/typecheck/TcDerivInfer.hs
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -7,23 +7,24 @@ Functions for inferring (and simplifying) the context for derived instances.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Bag
 import BasicTypes
 import Class
 import DataCon
--- import DynFlags
 import ErrUtils
 import Inst
 import Outputable
 import PrelNames
 import TcDerivUtils
 import TcEnv
--- import TcErrors (reportAllUnsolved)
 import TcGenFunctor
 import TcGenGenerics
 import TcMType
@@ -33,22 +34,22 @@ import TyCon
 import Type
 import TcSimplify
 import TcValidity (validDerivPred)
-import TcUnify (buildImplicationFor)
+import TcUnify (buildImplicationFor, checkConstraints)
 import Unify (tcUnifyTy)
 import Util
 import Var
-import VarEnv
 import VarSet
 
 import Control.Monad
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Reader (ask)
 import Data.List
 import Data.Maybe
 
 ----------------------
 
-inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
-                 -> TyCon -> [TcType] -> DerivSpecMechanism
-                 -> TcM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraints :: DerivSpecMechanism
+                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])
 -- inferConstraints figures out the constraints needed for the
 -- instance declaration generated by a 'deriving' clause on a
 -- data type declaration. It also returns the new in-scope type
@@ -64,171 +65,220 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
 -- Generate a sufficiently large set of constraints that typechecking the
 -- generated method definitions should succeed.   This set will be simplified
 -- before being used in the instance declaration
-inferConstraints tvs main_cls cls_tys inst_ty
-                 rep_tc rep_tc_args
-                 mechanism
-  | is_generic && not is_anyclass          -- Generic constraints are easy
-  = return ([], tvs, inst_tys)
-
-  | is_generic1 && not is_anyclass         -- Generic1 needs Functor
-  = ASSERT( rep_tc_tvs `lengthExceeds` 0 ) -- See Note [Getting base classes]
-    ASSERT( cls_tys `lengthIs` 1 )         -- Generic1 has a single kind variable
-    do { functorClass <- tcLookupClass functorClassName
-       ; con_arg_constraints (get_gen1_constraints functorClass) }
-
-  | otherwise  -- The others are a bit more complicated
-  = -- See the comment with all_rep_tc_args for an explanation of
-    -- this assertion
-    ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
-           , ppr main_cls <+> ppr rep_tc
-             $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
-      do { (arg_constraints, tvs', inst_tys') <- infer_constraints
-         ; traceTc "inferConstraints" $ vcat
-                [ ppr main_cls <+> ppr inst_tys'
-                , ppr arg_constraints
-                ]
-         ; return (stupid_constraints ++ extra_constraints
-                    ++ sc_constraints ++ arg_constraints
-                  , tvs', inst_tys') }
-  where
-    is_anyclass = isDerivSpecAnyClass mechanism
-    infer_constraints
-      | is_anyclass = inferConstraintsDAC main_cls tvs inst_tys
-      | otherwise   = con_arg_constraints get_std_constrained_tys
-
-    tc_binders = tyConBinders rep_tc
-    choose_level bndr
-      | isNamedTyConBinder bndr = KindLevel
-      | otherwise               = TypeLevel
-    t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
-       -- want to report *kind* errors when possible
-
-       -- Constraints arising from the arguments of each constructor
-    con_arg_constraints :: (CtOrigin -> TypeOrKind
-                                     -> Type
-                                     -> [([PredOrigin], Maybe TCvSubst)])
-                        -> TcM ([ThetaOrigin], [TyVar], [TcType])
-    con_arg_constraints get_arg_constraints
-      = let (predss, mbSubsts) = unzip
-              [ preds_and_mbSubst
-              | data_con <- tyConDataCons rep_tc
-              , (arg_n, arg_t_or_k, arg_ty)
-                  <- zip3 [1..] t_or_ks $
-                     dataConInstOrigArgTys data_con all_rep_tc_args
-                -- No constraints for unlifted types
-                -- See Note [Deriving and unboxed types]
-              , not (isUnliftedType arg_ty)
-              , let orig = DerivOriginDC data_con arg_n
-              , preds_and_mbSubst <- get_arg_constraints orig arg_t_or_k arg_ty
+inferConstraints mechanism
+  = do { DerivEnv { denv_tc          = tc
+                  , denv_tc_args     = tc_args
+                  , denv_cls         = main_cls
+                  , denv_cls_tys     = cls_tys } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
+       ; let is_anyclass = isDerivSpecAnyClass mechanism
+             infer_constraints
+               | is_anyclass = inferConstraintsDAC inst_tys
+               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys
+
+             inst_ty  = mkTyConApp tc tc_args
+             inst_tys = cls_tys ++ [inst_ty]
+
+             -- Constraints arising from superclasses
+             -- See Note [Superclasses of derived instance]
+             cls_tvs  = classTyVars main_cls
+             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
+                                     , ppr main_cls <+> ppr inst_tys )
+                              [ mkThetaOrigin (mkDerivOrigin wildcard)
+                                              TypeLevel [] [] [] $
+                                substTheta cls_subst (classSCTheta main_cls) ]
+             cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                         zipTvSubst cls_tvs inst_tys
+
+       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints
+       ; lift $ traceTc "inferConstraints" $ vcat
+              [ ppr main_cls <+> ppr inst_tys'
+              , ppr inferred_constraints
               ]
-            preds = concat predss
-            -- If the constraints require a subtype to be of kind (* -> *)
-            -- (which is the case for functor-like constraints), then we
-            -- explicitly unify the subtype's kinds with (* -> *).
-            -- See Note [Inferring the instance context]
-            subst        = foldl' composeTCvSubst
-                                  emptyTCvSubst (catMaybes mbSubsts)
-            unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
-                                      && not (v `isInScope` subst)) tvs
-            (subst', _)  = mapAccumL substTyVarBndr subst unmapped_tvs
-            preds'       = map (substPredOrigin subst') preds
-            inst_tys'    = substTys subst' inst_tys
-            tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
-        in return ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
-
-    is_generic  = main_cls `hasKey` genClassKey
-    is_generic1 = main_cls `hasKey` gen1ClassKey
-    -- is_functor_like: see Note [Inferring the instance context]
-    is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
-                   || is_generic1
-
-    get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
-                         -> [([PredOrigin], Maybe TCvSubst)]
-    get_gen1_constraints functor_cls orig t_or_k ty
-       = mk_functor_like_constraints orig t_or_k functor_cls $
-         get_gen1_constrained_tys last_tv ty
-
-    get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
-                            -> [([PredOrigin], Maybe TCvSubst)]
-    get_std_constrained_tys orig t_or_k ty
-        | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $
-                            deepSubtypesContaining last_tv ty
-        | otherwise       = [( [mk_cls_pred orig t_or_k main_cls ty]
-                             , Nothing )]
-
-    mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-                                -> Class -> [Type]
+       ; return ( sc_constraints ++ inferred_constraints
+                , tvs', inst_tys' ) }
+
+-- | Like 'inferConstraints', but used only in the case of deriving strategies
+-- where the constraints are inferred by inspecting the fields of each data
+-- constructor (i.e., stock- and newtype-deriving).
+inferConstraintsDataConArgs :: TcType -> [TcType]
+                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDataConArgs inst_ty inst_tys
+  = do DerivEnv { denv_tvs         = tvs
+                , denv_rep_tc      = rep_tc
+                , denv_rep_tc_args = rep_tc_args
+                , denv_cls         = main_cls
+                , denv_cls_tys     = cls_tys } <- ask
+       wildcard <- isStandaloneWildcardDeriv
+
+       let tc_binders = tyConBinders rep_tc
+           choose_level bndr
+             | isNamedTyConBinder bndr = KindLevel
+             | otherwise               = TypeLevel
+           t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
+              -- want to report *kind* errors when possible
+
+              -- Constraints arising from the arguments of each constructor
+           con_arg_constraints
+             :: (CtOrigin -> TypeOrKind
+                          -> Type
+                          -> [([PredOrigin], Maybe TCvSubst)])
+             -> ([ThetaOrigin], [TyVar], [TcType])
+           con_arg_constraints get_arg_constraints
+             = let (predss, mbSubsts) = unzip
+                     [ preds_and_mbSubst
+                     | data_con <- tyConDataCons rep_tc
+                     , (arg_n, arg_t_or_k, arg_ty)
+                         <- zip3 [1..] t_or_ks $
+                            dataConInstOrigArgTys data_con all_rep_tc_args
+                       -- No constraints for unlifted types
+                       -- See Note [Deriving and unboxed types]
+                     , not (isUnliftedType arg_ty)
+                     , let orig = DerivOriginDC data_con arg_n wildcard
+                     , preds_and_mbSubst
+                         <- get_arg_constraints orig arg_t_or_k arg_ty
+                     ]
+                   preds = concat predss
+                   -- If the constraints require a subtype to be of kind
+                   -- (* -> *) (which is the case for functor-like
+                   -- constraints), then we explicitly unify the subtype's
+                   -- kinds with (* -> *).
+                   -- See Note [Inferring the instance context]
+                   subst        = foldl' composeTCvSubst
+                                         emptyTCvSubst (catMaybes mbSubsts)
+                   unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
+                                             && not (v `isInScope` subst)) tvs
+                   (subst', _)  = substTyVarBndrs subst unmapped_tvs
+                   preds'       = map (substPredOrigin subst') preds
+                   inst_tys'    = substTys subst' inst_tys
+                   tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
+               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
+
+           is_generic  = main_cls `hasKey` genClassKey
+           is_generic1 = main_cls `hasKey` gen1ClassKey
+           -- is_functor_like: see Note [Inferring the instance context]
+           is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
+                          || is_generic1
+
+           get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
                                 -> [([PredOrigin], Maybe TCvSubst)]
-    -- 'cls' is usually main_cls (Functor or Traversable etc), but if
-    -- main_cls = Generic1, then 'cls' can be Functor; see get_gen1_constraints
-    --
-    -- For each type, generate two constraints, [cls ty, kind(ty) ~ (*->*)],
-    -- and a kind substitution that results from unifying kind(ty) with * -> *.
-    -- If the unification is successful, it will ensure that the resulting
-    -- instance is well kinded. If not, the second constraint will result
-    -- in an error message which points out the kind mismatch.
-    -- See Note [Inferring the instance context]
-    mk_functor_like_constraints orig t_or_k cls
-       = map $ \ty -> let ki = typeKind ty in
-                      ( [ mk_cls_pred orig t_or_k cls ty
-                        , mkPredOrigin orig KindLevel
-                            (mkPrimEqPred ki typeToTypeKind) ]
-                      , tcUnifyTy ki typeToTypeKind
-                      )
-
-    rep_tc_tvs      = tyConTyVars rep_tc
-    last_tv         = last rep_tc_tvs
-    -- When we first gather up the constraints to solve, most of them contain
-    -- rep_tc_tvs, i.e., the type variables from the derived datatype's type
-    -- constructor. We don't want these type variables to appear in the final
-    -- instance declaration, so we must substitute each type variable with its
-    -- counterpart in the derived instance. rep_tc_args lists each of these
-    -- counterpart types in the same order as the type variables.
-    all_rep_tc_args = rep_tc_args ++ map mkTyVarTy
-                                     (drop (length rep_tc_args) rep_tc_tvs)
-
-        -- Constraints arising from superclasses
-        -- See Note [Superclasses of derived instance]
-    cls_tvs  = classTyVars main_cls
-    inst_tys = cls_tys ++ [inst_ty]
-    sc_constraints = ASSERT2( equalLength cls_tvs inst_tys, ppr main_cls <+> ppr rep_tc)
-                     [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
-                       substTheta cls_subst (classSCTheta main_cls) ]
-    cls_subst = ASSERT( equalLength cls_tvs inst_tys )
-                zipTvSubst cls_tvs inst_tys
-
-        -- Stupid constraints
-    stupid_constraints = [ mkThetaOrigin DerivOrigin TypeLevel [] [] $
-                           substTheta tc_subst (tyConStupidTheta rep_tc) ]
-    tc_subst = -- See the comment with all_rep_tc_args for an explanation of
-               -- this assertion
-               ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
-               zipTvSubst rep_tc_tvs all_rep_tc_args
-
-        -- Extra Data constraints
-        -- The Data class (only) requires that for
-        --    instance (...) => Data (T t1 t2)
-        -- IF   t1:*, t2:*
-        -- THEN (Data t1, Data t2) are among the (...) constraints
-        -- Reason: when the IF holds, we generate a method
-        --             dataCast2 f = gcast2 f
-        --         and we need the Data constraints to typecheck the method
-    extra_constraints = [mkThetaOriginFromPreds constrs]
-      where
-        constrs
-          | main_cls `hasKey` dataClassKey
-          , all (isLiftedTypeKind . typeKind) rep_tc_args
-          = [ mk_cls_pred DerivOrigin t_or_k main_cls ty
-            | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
-          | otherwise
-          = []
-
-    mk_cls_pred orig t_or_k cls ty   -- Don't forget to apply to cls_tys' too
-       = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
-    cls_tys' | is_generic1 = [] -- In the awkward Generic1 case, cls_tys'
-                                -- should be empty, since we are applying the
-                                -- class Functor.
-             | otherwise   = cls_tys
+           get_gen1_constraints functor_cls orig t_or_k ty
+              = mk_functor_like_constraints orig t_or_k functor_cls $
+                get_gen1_constrained_tys last_tv ty
+
+           get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
+                                   -> [([PredOrigin], Maybe TCvSubst)]
+           get_std_constrained_tys orig t_or_k ty
+               | is_functor_like
+               = mk_functor_like_constraints orig t_or_k main_cls $
+                 deepSubtypesContaining last_tv ty
+               | otherwise
+               = [( [mk_cls_pred orig t_or_k main_cls ty]
+                  , Nothing )]
+
+           mk_functor_like_constraints :: CtOrigin -> TypeOrKind
+                                       -> Class -> [Type]
+                                       -> [([PredOrigin], Maybe TCvSubst)]
+           -- 'cls' is usually main_cls (Functor or Traversable etc), but if
+           -- main_cls = Generic1, then 'cls' can be Functor; see
+           -- get_gen1_constraints
+           --
+           -- For each type, generate two constraints,
+           -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results
+           -- from unifying  kind(ty) with * -> *. If the unification is
+           -- successful, it will ensure that the resulting instance is well
+           -- kinded. If not, the second constraint will result in an error
+           -- message which points out the kind mismatch.
+           -- See Note [Inferring the instance context]
+           mk_functor_like_constraints orig t_or_k cls
+              = map $ \ty -> let ki = typeKind ty in
+                             ( [ mk_cls_pred orig t_or_k cls ty
+                               , mkPredOrigin orig KindLevel
+                                   (mkPrimEqPred ki typeToTypeKind) ]
+                             , tcUnifyTy ki typeToTypeKind
+                             )
+
+           rep_tc_tvs      = tyConTyVars rep_tc
+           last_tv         = last rep_tc_tvs
+           -- When we first gather up the constraints to solve, most of them
+           -- contain rep_tc_tvs, i.e., the type variables from the derived
+           -- datatype's type constructor. We don't want these type variables
+           -- to appear in the final instance declaration, so we must
+           -- substitute each type variable with its counterpart in the derived
+           -- instance. rep_tc_args lists each of these counterpart types in
+           -- the same order as the type variables.
+           all_rep_tc_args
+             = rep_tc_args ++ map mkTyVarTy
+                                  (drop (length rep_tc_args) rep_tc_tvs)
+
+               -- Stupid constraints
+           stupid_constraints
+             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $
+                 substTheta tc_subst (tyConStupidTheta rep_tc) ]
+           tc_subst = -- See the comment with all_rep_tc_args for an
+                      -- explanation of this assertion
+                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+                      zipTvSubst rep_tc_tvs all_rep_tc_args
+
+           -- Extra Data constraints
+           -- The Data class (only) requires that for
+           --    instance (...) => Data (T t1 t2)
+           -- IF   t1:*, t2:*
+           -- THEN (Data t1, Data t2) are among the (...) constraints
+           -- Reason: when the IF holds, we generate a method
+           --             dataCast2 f = gcast2 f
+           --         and we need the Data constraints to typecheck the method
+           extra_constraints = [mkThetaOriginFromPreds constrs]
+             where
+               constrs
+                 | main_cls `hasKey` dataClassKey
+                 , all (isLiftedTypeKind . typeKind) rep_tc_args
+                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty
+                   | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
+                 | otherwise
+                 = []
+
+           mk_cls_pred orig t_or_k cls ty
+                -- Don't forget to apply to cls_tys' too
+              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
+           cls_tys' | is_generic1 = []
+                      -- In the awkward Generic1 case, cls_tys' should be
+                      -- empty, since we are applying the class Functor.
+
+                    | otherwise   = cls_tys
+
+           deriv_origin = mkDerivOrigin wildcard
+
+       if    -- Generic constraints are easy
+          |  is_generic
+           -> return ([], tvs, inst_tys)
+
+             -- Generic1 needs Functor
+             -- See Note [Getting base classes]
+          |  is_generic1
+           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )
+              -- Generic1 has a single kind variable
+              ASSERT( cls_tys `lengthIs` 1 )
+              do { functorClass <- lift $ tcLookupClass functorClassName
+                 ; pure $ con_arg_constraints
+                        $ get_gen1_constraints functorClass }
+
+             -- The others are a bit more complicated
+          |  otherwise
+           -> -- See the comment with all_rep_tc_args for an explanation of
+              -- this assertion
+              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
+                     , ppr main_cls <+> ppr rep_tc
+                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+                do { let (arg_constraints, tvs', inst_tys')
+                           = con_arg_constraints get_std_constrained_tys
+                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat
+                          [ ppr main_cls <+> ppr inst_tys'
+                          , ppr arg_constraints
+                          ]
+                   ; return ( stupid_constraints ++ extra_constraints
+                                                 ++ arg_constraints
+                            , tvs', inst_tys') }
 
 typeToTypeKind :: Kind
 typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
@@ -240,61 +290,63 @@ typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
 -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
 -- for an explanation of how these constraints are used to determine the
 -- derived instance context.
-inferConstraintsDAC :: Class -> [TyVar] -> [TcType]
-                    -> TcM ([ThetaOrigin], [TyVar], [TcType])
-inferConstraintsDAC cls tvs inst_tys
-  = do { let gen_dms = [ (sel_id, dm_ty)
-                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
+inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDAC inst_tys
+  = do { DerivEnv { denv_tvs = tvs
+                  , denv_cls = cls } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
 
-       ; theta_origins <- pushTcLevelM_ (mapM do_one_meth gen_dms)
-            -- Yuk: the pushTcLevel is to match the one wrapping the call
-            --      to mk_wanteds in simplifyDeriv.  If we omit this, the
-            --      unification variables will wrongly be untouchable.
+       ; let gen_dms = [ (sel_id, dm_ty)
+                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
 
+             cls_tvs = classTyVars cls
+
+             do_one_meth :: (Id, Type) -> TcM ThetaOrigin
+               -- (Id,Type) are the selector Id and the generic default method type
+               -- NB: the latter is /not/ quantified over the class variables
+               -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+             do_one_meth (sel_id, gen_dm_ty)
+               = do { let (sel_tvs, _cls_pred, meth_ty)
+                                   = tcSplitMethodTy (varType sel_id)
+                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty
+                          (meth_tvs, meth_theta, meth_tau)
+                                   = tcSplitNestedSigmaTys meth_ty'
+
+                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty
+                          (dm_tvs, dm_theta, dm_tau)
+                                     = tcSplitNestedSigmaTys gen_dm_ty'
+                          tau_eq     = mkPrimEqPred meth_tau dm_tau
+                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel
+                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }
+
+       ; theta_origins <- lift $ mapM do_one_meth gen_dms
        ; return (theta_origins, tvs, inst_tys) }
-  where
-    cls_tvs = classTyVars cls
-    empty_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tvs))
-
-    do_one_meth :: (Id, Type) -> TcM ThetaOrigin
-      -- (Id,Type) are the selector Id and the generic default method type
-      -- NB: the latter is /not/ quantified over the class variables
-      -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
-    do_one_meth (sel_id, gen_dm_ty)
-      = do { let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)
-                 meth_ty' = substTyWith sel_tvs inst_tys meth_ty
-                 (meth_tvs, meth_theta, meth_tau) = tcSplitNestedSigmaTys meth_ty'
-
-                 gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty
-                 (dm_tvs, dm_theta, dm_tau) = tcSplitNestedSigmaTys gen_dm_ty'
-
-           ; (subst, _meta_tvs) <- pushTcLevelM_ $
-                                   newMetaTyVarsX empty_subst dm_tvs
-                -- Yuk: the pushTcLevel is to match the one in mk_wanteds
-                --      simplifyDeriv.  If we don't, the unification variables
-                --      will bogusly be untouchable.
-           ; let dm_theta' = substTheta subst dm_theta
-                 tau_eq    = mkPrimEqPred meth_tau (substTy subst dm_tau)
-           ; return (mkThetaOrigin DerivOrigin TypeLevel
-                                   meth_tvs meth_theta (tau_eq:dm_theta')) }
 
 {- Note [Inferring the instance context]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two sorts of 'deriving':
+There are two sorts of 'deriving', as represented by the two constructors
+for DerivContext:
+
+  * InferContext mb_wildcard: This can either be:
+    - The deriving clause for a data type.
+        (e.g, data T a = T1 a deriving( Eq ))
+      In this case, mb_wildcard = Nothing.
+    - A standalone declaration with an extra-constraints wildcard
+        (e.g., deriving instance _ => Eq (Foo a))
+      In this case, mb_wildcard = Just loc, where loc is the location
+      of the extra-constraints wildcard.
 
-  * InferTheta: the deriving clause for a data type
-      data T a = T1 a deriving( Eq )
     Here we must infer an instance context,
     and generate instance declaration
       instance Eq a => Eq (T a) where ...
 
-  * CheckTheta: standalone deriving
+  * SupplyContext theta: standalone deriving
       deriving instance Eq a => Eq (T a)
     Here we only need to fill in the bindings;
-    the instance context is user-supplied
+    the instance context (theta) is user-supplied
 
-For a deriving clause (InferTheta) we must figure out the
-instance context (inferConstraints). Suppose we are inferring
+For the InferContext case, we must figure out the
+instance context (inferConstraintsDataConArgs). Suppose we are inferring
 the instance context for
     C t1 .. tn (T s1 .. sm)
 There are two cases
@@ -346,7 +398,7 @@ We have some special hacks to support things like
    data T = MkT Int# deriving ( Show )
 
 Specifically, we use TcGenDeriv.box to box the Int# into an Int
-(which we know how to show), and append a '#'. Parenthesis are not required
+(which we know how to show), and append a '#'. Parentheses are not required
 for unboxed values (`MkT -3#` is a valid expression).
 
 Note [Superclasses of derived instance]
@@ -404,7 +456,7 @@ Let's call the context reqd for the T instance of class C at types
         Eq (T a b) = (Ping a, Pong b, ...)
 
 Now we can get a (recursive) equation from the data decl.  This part
-is done by inferConstraints.
+is done by inferConstraintsDataConArgs.
 
         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
                    u Eq (T b a) u Eq Int        -- From C2
@@ -485,8 +537,8 @@ See also Note [nonDetCmpType nondeterminism]
 
 simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]
                          -> TcM [DerivSpec ThetaType]
--- Used only for deriving clauses (InferTheta)
--- not for standalone deriving
+-- Used only for deriving clauses or standalone deriving with an
+-- extra-constraints wildcard (InferContext)
 -- See Note [Simplifying the instance context]
 
 simplifyInstanceContexts [] = return []
@@ -586,9 +638,25 @@ simplifyDeriv pred tvs thetas
                let given_pred = substTy skol_subst given
                in newEvVar given_pred
 
-             mk_wanted_ct :: PredOrigin -> TcM CtEvidence
-             mk_wanted_ct (PredOrigin wanted o t_or_k)
-               = newWanted o (Just t_or_k) (substTyUnchecked skol_subst wanted)
+             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()
+             emit_wanted_constraints metas_to_be preds
+               = do { -- We instantiate metas_to_be with fresh meta type
+                      -- variables. Currently, these can only be type variables
+                      -- quantified in generic default type signatures.
+                      -- See Note [Gathering and simplifying constraints for
+                      -- DeriveAnyClass]
+                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be
+
+                    -- Now make a constraint for each of the instantiated predicates
+                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst
+                          mk_wanted_ct (PredOrigin wanted orig t_or_k)
+                            = do { ev <- newWanted orig (Just t_or_k) $
+                                         substTyUnchecked wanted_subst wanted
+                                 ; return (mkNonCanonical ev) }
+                    ; cts <- mapM mk_wanted_ct preds
+
+                    -- And emit them into the monad
+                    ; emitSimples (listToCts cts) }
 
              -- Create the implications we need to solve. For stock and newtype
              -- deriving, these implication constraints will be simple class
@@ -596,39 +664,49 @@ simplifyDeriv pred tvs thetas
              -- But with DeriveAnyClass, we make an implication constraint.
              -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
              mk_wanteds :: ThetaOrigin -> TcM WantedConstraints
-             mk_wanteds (ThetaOrigin { to_tvs            = local_skols
-                                     , to_givens         = givens
-                                     , to_wanted_origins = wanteds })
-               | null local_skols, null givens
-               = do { wanted_cts <- mapM mk_wanted_ct wanteds
-                    ; return (mkSimpleWC wanted_cts) }
-               | otherwise
-               = do { given_evs <- mapM mk_given_ev givens
-                    ; (wanted_cts, tclvl) <- pushTcLevelM $
-                                             mapM mk_wanted_ct wanteds
-                    ; (implic, _) <- buildImplicationFor tclvl skol_info local_skols
-                                                   given_evs (mkSimpleWC wanted_cts)
-                    ; pure (mkImplicWC implic) }
+             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols
+                                     , to_anyclass_metas  = ac_metas
+                                     , to_anyclass_givens = ac_givens
+                                     , to_wanted_origins  = preds })
+               = do { ac_given_evs <- mapM mk_given_ev ac_givens
+                    ; (_, wanteds)
+                        <- captureConstraints $
+                           checkConstraints skol_info ac_skols ac_given_evs $
+                              -- The checkConstraints bumps the TcLevel, and
+                              -- wraps the wanted constraints in an implication,
+                              -- when (but only when) necessary
+                           emit_wanted_constraints ac_metas preds
+                    ; pure wanteds }
 
        -- See [STEP DAC BUILD]
-       -- Generate the implication constraints constraints to solve with the
-       -- skolemized variables
-       ; (wanteds, tclvl) <- pushTcLevelM $ mapM mk_wanteds thetas
+       -- Generate the implication constraints, one for each method, to solve
+       -- with the skolemized variables.  Start "one level down" because
+       -- we are going to wrap the result in an implication with tvs_skols,
+       -- in step [DAC RESIDUAL]
+       ; (wanteds, tc_lvl) <- pushTcLevelM $
+                              mapM mk_wanteds thetas
 
        ; traceTc "simplifyDeriv inputs" $
          vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]
 
        -- See [STEP DAC SOLVE]
-       -- Simplify the constraints
-       ; solved_implics <- runTcSDeriveds $ solveWantedsAndDrop
-                                          $ unionsWC wanteds
+       -- Simplify the constraints, starting at the same level at which
+       -- they are generated (c.f. the call to runTcSWithEvBinds in
+       -- simplifyInfer)
+       ; solved_wanteds <- setTcLevel tc_lvl   $
+                           runTcSDeriveds      $
+                           solveWantedsAndDrop $
+                           unionsWC wanteds
+
+       -- It's not yet zonked!  Obviously zonk it before peering at it
+       ; solved_wanteds <- zonkWC solved_wanteds
 
        -- See [STEP DAC HOIST]
        -- Split the resulting constraints into bad and good constraints,
        -- building an @unsolved :: WantedConstraints@ representing all
        -- the constraints we can't just shunt to the predicates.
        -- See Note [Exotic derived instance contexts]
-       ; let residual_simple = approximateWC True solved_implics
+       ; let residual_simple = approximateWC True solved_wanteds
              (bad, good) = partitionBagWith get_good residual_simple
 
              get_good :: Ct -> Either Ct PredType
@@ -648,7 +726,7 @@ simplifyDeriv pred tvs thetas
          vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
 
        -- Return the good unsolved constraints (unskolemizing on the way out.)
-       ; let min_theta = mkMinimalBySCs (bagToList good)
+       ; let min_theta = mkMinimalBySCs id (bagToList good)
              -- An important property of mkMinimalBySCs (used above) is that in
              -- addition to removing constraints that are made redundant by
              -- superclass relationships, it also removes _duplicate_
@@ -660,8 +738,9 @@ simplifyDeriv pred tvs thetas
 
        -- See [STEP DAC RESIDUAL]
        ; min_theta_vars <- mapM newEvVar min_theta
-       ; (leftover_implic, _) <- buildImplicationFor tclvl skol_info tvs_skols
-                                   min_theta_vars solved_implics
+       ; (leftover_implic, _)
+           <- buildImplicationFor tc_lvl skol_info tvs_skols
+                                  min_theta_vars solved_wanteds
        -- This call to simplifyTop is purely for error reporting
        -- See Note [Error reporting for deriving clauses]
        -- See also Note [Exotic derived instance contexts], which are caught
@@ -674,8 +753,8 @@ simplifyDeriv pred tvs thetas
 Note [Overlap and deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider some overlapping instances:
-  data Show a => Show [a] where ..
-  data Show [Char] where ...
+  instance Show a => Show [a] where ..
+  instance Show [Char] where ...
 
 Now a data type with deriving:
   data T a = MkT [a] deriving( Show )
@@ -737,39 +816,57 @@ GHC were typechecking the binding
    bar = $gdm bar
 it would
    * skolemise the expected type of bar
-   * instantiate the type of $dm_bar with meta-type variables
+   * instantiate the type of $gdm_bar with meta-type variables
    * build an implication constraint
 
 [STEP DAC BUILD]
 So that's what we do.  We build the constraint (call it C1)
 
-   forall b. Ix b => (Show (Maybe s), Ix cc,
-                      Maybe s -> b -> String
-                          ~ Maybe s -> cc -> String)
+   forall[2] b. Ix b => (Show (Maybe s), Ix cc,
+                        Maybe s -> b -> String
+                            ~ Maybe s -> cc -> String)
+
+Here:
+* The level of this forall constraint is forall[2], because we are later
+  going to wrap it in a forall[1] in [STEP DAC RESIDUAL]
+
+* The 'b' comes from the quantified type variable in the expected type
+  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification
+  variable that comes from instantiating the quantified type variable 'c' in
+  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).
+
+* The (Ix b) constraint comes from the context of bar's type
+  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)
+  constraints come from the context of $gdm_bar's type
+  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').
+
+* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)
+  comes from marrying up the instantiated type of $gdm_bar with the specified
+  type of bar. Notice that the type variables from the instance, 's' in this
+  case, are global to this constraint.
 
-The 'cc' is a unification variable that comes from instantiating
-$dm_bar's type.  The equality constraint comes from marrying up
-the instantiated type of $dm_bar with the specified type of bar.
-Notice that the type variables from the instance, 's' in this case,
-are global to this constraint.
+Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new
+unification variable for each iteration of simplifyDeriv. If we re-use the same
+unification variable across multiple iterations, then bad things can happen,
+such as Trac #14933.
 
 Similarly for 'baz', givng the constraint C2
 
-   forall. Eq (Maybe s) => (Ord a, Show a,
-                            Maybe s -> Maybe s -> Bool
+   forall[2]. Eq (Maybe s) => (Ord a, Show a,
+                              Maybe s -> Maybe s -> Bool
                                 ~ Maybe s -> Maybe s -> Bool)
 
 In this case baz has no local quantification, so the implication
-constraint has no local skolems and there are no unificaiton
+constraint has no local skolems and there are no unification
 variables.
 
 [STEP DAC SOLVE]
 We can combine these two implication constraints into a single
 constraint (C1, C2), and simplify, unifying cc:=b, to get:
 
-   forall b. Ix b => Show a
+   forall[2] b. Ix b => Show a
    /\
-   forall. Eq (Maybe s) => (Ord a, Show a)
+   forall[2]. Eq (Maybe s) => (Ord a, Show a)
 
 [STEP DAC HOIST]
 Let's call that (C1', C2').  Now we need to hoist the unsolved
@@ -788,7 +885,7 @@ And that's what GHC uses for CX.
 In this case we have solved all the leftover constraints, but what if
 we don't?  Simple!  We just form the final residual constraint
 
-   forall s. CX => (C1',C2')
+   forall[1] s. CX => (C1',C2')
 
 and simplify that. In simple cases it'll succeed easily, because CX
 literally contains the constraints in C1', C2', but if there is anything
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index 09876afb70..86205de5fd 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -6,22 +6,25 @@
 Error-checking and other utilities for @deriving@ clauses or declarations.
 -}
 
-{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module TcDerivUtils (
+        DerivM, DerivEnv(..),
         DerivSpec(..), pprDerivSpec,
-        DerivSpecMechanism(..), isDerivSpecStock,
-        isDerivSpecNewtype, isDerivSpecAnyClass,
-        DerivContext, DerivStatus(..),
+        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
+        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
+        DerivContext(..), OriginativeDerivStatus(..),
+        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
         PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
         mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
-        checkSideConditions, hasStockDeriving,
+        checkOriginativeSideConditions, hasStockDeriving,
         canDeriveAnyClass,
         std_class_via_coercible, non_coercible_class,
         newDerivClsInst, extendLocalInstEnv
     ) where
 
+import GhcPrelude
+
 import Bag
 import BasicTypes
 import Class
@@ -49,18 +52,109 @@ import Type
 import Util
 import VarSet
 
+import Control.Monad.Trans.Reader
+import Data.Maybe
 import qualified GHC.LanguageExtensions as LangExt
 import ListSetOps (assocMaybe)
 
-data DerivSpec theta = DS { ds_loc       :: SrcSpan
-                          , ds_name      :: Name         -- DFun name
-                          , ds_tvs       :: [TyVar]
-                          , ds_theta     :: theta
-                          , ds_cls       :: Class
-                          , ds_tys       :: [Type]
-                          , ds_tc        :: TyCon
-                          , ds_overlap   :: Maybe OverlapMode
-                          , ds_mechanism :: DerivSpecMechanism }
+-- | To avoid having to manually plumb everything in 'DerivEnv' throughout
+-- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which
+-- is a simple reader around 'TcRn'.
+type DerivM = ReaderT DerivEnv TcRn
+
+-- | Is GHC processing a stanalone deriving declaration?
+isStandaloneDeriv :: DerivM Bool
+isStandaloneDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = True
+
+-- | Is GHC processing a standalone deriving declaration with an
+-- extra-constraints wildcard as the context?
+-- (e.g., @deriving instance _ => Eq (Foo a)@)
+isStandaloneWildcardDeriv :: DerivM Bool
+isStandaloneWildcardDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = False
+
+-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
+mkDerivOrigin :: Bool -> CtOrigin
+mkDerivOrigin standalone_wildcard
+  | standalone_wildcard = StandAloneDerivOrigin
+  | otherwise           = DerivClauseOrigin
+
+-- | Contains all of the information known about a derived instance when
+-- determining what its @EarlyDerivSpec@ should be.
+data DerivEnv = DerivEnv
+  { denv_overlap_mode :: Maybe OverlapMode
+    -- ^ Is this an overlapping instance?
+  , denv_tvs          :: [TyVar]
+    -- ^ Universally quantified type variables in the instance
+  , denv_cls          :: Class
+    -- ^ Class for which we need to derive an instance
+  , denv_cls_tys      :: [Type]
+    -- ^ Other arguments to the class except the last
+  , denv_tc           :: TyCon
+    -- ^ Type constructor for which the instance is requested
+    --   (last arguments to the type class)
+  , denv_tc_args      :: [Type]
+    -- ^ Arguments to the type constructor
+  , denv_rep_tc       :: TyCon
+    -- ^ The representation tycon for 'denv_tc'
+    --   (for data family instances)
+  , denv_rep_tc_args  :: [Type]
+    -- ^ The representation types for 'denv_tc_args'
+    --   (for data family instances)
+  , denv_ctxt         :: DerivContext
+    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
+    --   context of the instance).
+    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
+    --   uses a wildcard constraint.
+    --   See @Note [Inferring the instance context]@.
+  , denv_strat        :: Maybe (DerivStrategy GhcTc)
+    -- ^ 'Just' if user requests a particular deriving strategy.
+    --   Otherwise, 'Nothing'.
+  }
+
+instance Outputable DerivEnv where
+  ppr (DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_ctxt         = ctxt
+                , denv_strat        = mb_strat })
+    = hang (text "DerivEnv")
+         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
+                 , text "denv_tvs"          <+> ppr tvs
+                 , text "denv_cls"          <+> ppr cls
+                 , text "denv_cls_tys"      <+> ppr cls_tys
+                 , text "denv_tc"           <+> ppr tc
+                 , text "denv_tc_args"      <+> ppr tc_args
+                 , text "denv_rep_tc"       <+> ppr rep_tc
+                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args
+                 , text "denv_ctxt"         <+> ppr ctxt
+                 , text "denv_strat"        <+> ppr mb_strat ])
+
+data DerivSpec theta = DS { ds_loc                 :: SrcSpan
+                          , ds_name                :: Name         -- DFun name
+                          , ds_tvs                 :: [TyVar]
+                          , ds_theta               :: theta
+                          , ds_cls                 :: Class
+                          , ds_tys                 :: [Type]
+                          , ds_tc                  :: TyCon
+                          , ds_overlap             :: Maybe OverlapMode
+                          , ds_standalone_wildcard :: Maybe SrcSpan
+                              -- See Note [Inferring the instance context]
+                              -- in TcDerivInfer
+                          , ds_mechanism           :: DerivSpecMechanism }
         -- This spec implies a dfun declaration of the form
         --       df :: forall tvs. theta => C tys
         -- The Name is the name for the DFun we'll build
@@ -90,15 +184,17 @@ Example:
 
 pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
-                   ds_tys = tys, ds_theta = rhs, ds_mechanism = mech })
+                   ds_tys = tys, ds_theta = rhs,
+                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
   = hang (text "DerivSpec")
-       2 (vcat [ text "ds_loc       =" <+> ppr l
-               , text "ds_name      =" <+> ppr n
-               , text "ds_tvs       =" <+> ppr tvs
-               , text "ds_cls       =" <+> ppr c
-               , text "ds_tys       =" <+> ppr tys
-               , text "ds_theta     =" <+> ppr rhs
-               , text "ds_mechanism =" <+> ppr mech ])
+       2 (vcat [ text "ds_loc                  =" <+> ppr l
+               , text "ds_name                 =" <+> ppr n
+               , text "ds_tvs                  =" <+> ppr tvs
+               , text "ds_cls                  =" <+> ppr c
+               , text "ds_tys                  =" <+> ppr tys
+               , text "ds_theta                =" <+> ppr rhs
+               , text "ds_standalone_wildcard  =" <+> ppr wildcard
+               , text "ds_mechanism            =" <+> ppr mech ])
 
 instance Outputable theta => Outputable (DerivSpec theta) where
   ppr = pprDerivSpec
@@ -129,7 +225,17 @@ data DerivSpecMechanism
 
   | DerivSpecAnyClass -- -XDeriveAnyClass
 
-isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass
+  | DerivSpecVia -- -XDerivingVia
+      Type -- The @via@ type
+
+-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
+derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
+derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy
+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy
+derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy
+derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t
+
+isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
   :: DerivSpecMechanism -> Bool
 isDerivSpecStock (DerivSpecStock{}) = True
 isDerivSpecStock _                  = False
@@ -137,96 +243,160 @@ isDerivSpecStock _                  = False
 isDerivSpecNewtype (DerivSpecNewtype{}) = True
 isDerivSpecNewtype _                    = False
 
-isDerivSpecAnyClass (DerivSpecAnyClass{}) = True
-isDerivSpecAnyClass _                     = False
+isDerivSpecAnyClass DerivSpecAnyClass = True
+isDerivSpecAnyClass _                 = False
 
--- A DerivSpecMechanism can be losslessly converted to a DerivStrategy.
-mechanismToStrategy :: DerivSpecMechanism -> DerivStrategy
-mechanismToStrategy (DerivSpecStock{})    = StockStrategy
-mechanismToStrategy (DerivSpecNewtype{})  = NewtypeStrategy
-mechanismToStrategy (DerivSpecAnyClass{}) = AnyclassStrategy
+isDerivSpecVia (DerivSpecVia{}) = True
+isDerivSpecVia _                = False
 
 instance Outputable DerivSpecMechanism where
-  ppr = ppr . mechanismToStrategy
-
-type DerivContext = Maybe ThetaType
-   -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
-   -- Just theta <=> Standalone deriving: context supplied by programmer
-
-data DerivStatus = CanDerive                 -- Stock class, can derive
-                 | DerivableClassError SDoc  -- Stock class, but can't do it
-                 | DerivableViaInstance      -- See Note [Deriving any class]
-                 | NonDerivableClass SDoc    -- Non-stock class
+  ppr (DerivSpecStock{})   = text "DerivSpecStock"
+  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t
+  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"
+  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t
+
+-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
+-- declaration.
+data DerivContext
+  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
+                                 --
+                                 -- * A @deriving@ clause (in which case
+                                 --   @mb_wildcard@ is 'Nothing').
+                                 --
+                                 -- * A standalone deriving declaration with
+                                 --   an extra-constraints wildcard as the
+                                 --   context (in which case @mb_wildcard@ is
+                                 --   @'Just' loc@, where @loc@ is the location
+                                 --   of the wildcard.
+                                 --
+                                 -- GHC should infer the context.
+
+  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
+                                 -- deriving declaration, where @theta@ is the
+                                 -- context supplied by the user.
+
+instance Outputable DerivContext where
+  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
+  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta
+
+-- | Records whether a particular class can be derived by way of an
+-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
+--
+-- See @Note [Deriving strategies]@ in "TcDeriv".
+data OriginativeDerivStatus
+  = CanDeriveStock            -- Stock class, can derive
+      (SrcSpan -> TyCon -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+  | StockClassError SDoc      -- Stock class, but can't do it
+  | CanDeriveAnyClass         -- See Note [Deriving any class]
+  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass
 
 -- A stock class is one either defined in the Haskell report or for which GHC
 -- otherwise knows how to generate code for (possibly requiring the use of a
--- language extension), such as Eq, Ord, Ix, Data, Generic, etc.
+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)
 
 -- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
 -- and whether or the constraint deals in types or kinds.
 data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
 
--- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') alongside
--- any corresponding given constraints ('to_givens') and locally quantified
--- type variables ('to_tvs').
+-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to
+-- simplify when inferring a derived instance's context. These are used in all
+-- deriving strategies, but in the particular case of @DeriveAnyClass@, we
+-- need extra information. In particular, we need:
+--
+-- * 'to_anyclass_skols', the list of type variables bound by a class method's
+--   regular type signature, which should be rigid.
+--
+-- * 'to_anyclass_metas', the list of type variables bound by a class method's
+--   default type signature. These can be unified as necessary.
 --
--- In most cases, 'to_givens' will be empty, as most deriving mechanisms (e.g.,
--- stock and newtype deriving) do not require given constraints. The exception
--- is @DeriveAnyClass@, which can involve given constraints. For example,
--- if you tried to derive an instance for the following class using
--- @DeriveAnyClass@:
+-- * 'to_anyclass_givens', the list of constraints from a class method's
+--   regular type signature, which can be used to help solve constraints
+--   in the 'to_wanted_origins'.
+--
+-- (Note that 'to_wanted_origins' will likely contain type variables from the
+-- derived type class or data type, neither of which will appear in
+-- 'to_anyclass_skols' or 'to_anyclass_metas'.)
+--
+-- For all other deriving strategies, it is always the case that
+-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are
+-- empty.
+--
+-- Here is an example to illustrate this:
 --
 -- @
 -- class Foo a where
---   bar :: a -> b -> String
---   default bar :: (Show a, Ix b) => a -> b -> String
---   bar = show
+--   bar :: forall b. Ix b => a -> b -> String
+--   default bar :: forall y. (Show a, Ix y) => a -> y -> String
+--   bar x y = show x ++ show (range (y, y))
 --
 --   baz :: Eq a => a -> a -> Bool
 --   default baz :: Ord a => a -> a -> Bool
 --   baz x y = compare x y == EQ
+--
+-- data Quux q = Quux deriving anyclass Foo
 -- @
 --
 -- Then it would generate two 'ThetaOrigin's, one for each method:
 --
 -- @
--- [ ThetaOrigin { to_tvs            = [b]
---               , to_givens         = []
---               , to_wanted_origins = [Show a, Ix b] }
--- , ThetaOrigin { to_tvs            = []
---               , to_givens         = [Eq a]
---               , to_wanted_origins = [Ord a] }
+-- [ ThetaOrigin { to_anyclass_skols  = [b]
+--               , to_anyclass_metas  = [y]
+--               , to_anyclass_givens = [Ix b]
+--               , to_wanted_origins  = [ Show (Quux q), Ix y
+--                                      , (Quux q -> b -> String) ~
+--                                        (Quux q -> y -> String)
+--                                      ] }
+-- , ThetaOrigin { to_anyclass_skols  = []
+--               , to_anyclass_metas  = []
+--               , to_anyclass_givens = [Eq (Quux q)]
+--               , to_wanted_origins  = [ Ord (Quux q)
+--                                      , (Quux q -> Quux q -> Bool) ~
+--                                        (Quux q -> Quux q -> Bool)
+--                                      ] }
 -- ]
 -- @
+--
+-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
+-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)
+--
+-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
+-- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are
+-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',
+-- 'to_anyclass_metas', and 'to_anyclass_givens' are used.
 data ThetaOrigin
-  = ThetaOrigin { to_tvs            :: [TyVar]
-                , to_givens         :: ThetaType
-                , to_wanted_origins :: [PredOrigin] }
+  = ThetaOrigin { to_anyclass_skols  :: [TyVar]
+                , to_anyclass_metas  :: [TyVar]
+                , to_anyclass_givens :: ThetaType
+                , to_wanted_origins  :: [PredOrigin] }
 
 instance Outputable PredOrigin where
   ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
 
 instance Outputable ThetaOrigin where
-  ppr (ThetaOrigin { to_tvs = tvs
-                   , to_givens = givens
-                   , to_wanted_origins = wanted_origins })
+  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols
+                   , to_anyclass_metas  = ac_metas
+                   , to_anyclass_givens = ac_givens
+                   , to_wanted_origins  = wanted_origins })
     = hang (text "ThetaOrigin")
-         2 (vcat [ text "to_tvs            =" <+> ppr tvs
-                 , text "to_givens         =" <+> ppr givens
-                 , text "to_wanted_origins =" <+> ppr wanted_origins ])
+         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols
+                 , text "to_anyclass_metas  =" <+> ppr ac_metas
+                 , text "to_anyclass_givens =" <+> ppr ac_givens
+                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])
 
 mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
 mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
 
-mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> ThetaType -> ThetaType
+mkThetaOrigin :: CtOrigin -> TypeOrKind
+              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType
               -> ThetaOrigin
-mkThetaOrigin origin t_or_k tvs givens
-  = ThetaOrigin tvs givens . map (mkPredOrigin origin t_or_k)
+mkThetaOrigin origin t_or_k skols metas givens
+  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)
 
 -- A common case where the ThetaOrigin only contains wanted constraints, with
 -- no givens or locally scoped type variables.
 mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
-mkThetaOriginFromPreds = ThetaOrigin [] []
+mkThetaOriginFromPreds = ThetaOrigin [] [] []
 
 substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
 substPredOrigin subst (PredOrigin pred origin t_or_k)
@@ -241,9 +411,9 @@ substPredOrigin subst (PredOrigin pred origin t_or_k)
 
 Only certain blessed classes can be used in a deriving clause (without the
 assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
-are listed below in the definition of hasStockDeriving. The sideConditions
+are listed below in the definition of hasStockDeriving. The stockSideConditions
 function determines the criteria that needs to be met in order for a particular
-class to be able to be derived successfully.
+stock class to be able to be derived successfully.
 
 A class might be able to be used in a deriving clause if -XDeriveAnyClass
 is willing to support it. The canDeriveAnyClass function checks if this is the
@@ -349,35 +519,43 @@ getDataConFixityFun tc
     doc = text "Data con fixities for" <+> ppr name
 
 ------------------------------------------------------------------
--- Check side conditions that dis-allow derivability for particular classes
--- This is *apart* from the newtype-deriving mechanism
+-- Check side conditions that dis-allow derivability for the originative
+-- deriving strategies (stock and anyclass).
+-- See Note [Deriving strategies] in TcDeriv for an explanation of what
+-- "originative" means.
+--
+-- This is *apart* from the coerce-based strategies, newtype and via.
 --
 -- Here we get the representation tycon in case of family instances as it has
 -- the data constructors - but we need to be careful to fall back to the
 -- family tycon (with indexes) in error messages.
 
-checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType]
-                    -> TyCon -- tycon
-                    -> DerivStatus
-checkSideConditions dflags mtheta cls cls_tys rep_tc
-  | Just cond <- sideConditions mtheta cls
-  = case (cond dflags rep_tc) of
-        NotValid err -> DerivableClassError err  -- Class-specific error
+checkOriginativeSideConditions
+  :: DynFlags -> DerivContext -> Class -> [TcType]
+  -> TyCon -> TyCon
+  -> OriginativeDerivStatus
+checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+    -- First, check if stock deriving is possible...
+  | Just cond <- stockSideConditions deriv_ctxt cls
+  = case (cond dflags tc rep_tc) of
+        NotValid err -> StockClassError err  -- Class-specific error
         IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-                   -> CanDerive
                    -- All stock derivable classes are unary in the sense that
                    -- there should be not types in cls_tys (i.e., no type args
                    -- other than last). Note that cls_types can contain
                    -- invisible types as well (e.g., for Generic1, which is
                    -- poly-kinded), so make sure those are not counted.
-                 | otherwise -> DerivableClassError (classArgsErr cls cls_tys)
+                 , Just gen_fn <- hasStockDeriving cls
+                   -> CanDeriveStock gen_fn
+                 | otherwise -> StockClassError (classArgsErr cls cls_tys)
                    -- e.g. deriving( Eq s )
 
+    -- ...if not, try falling back on DeriveAnyClass.
   | NotValid err <- canDeriveAnyClass dflags
-  = NonDerivableClass err  -- DeriveAnyClass does not work
+  = NonDerivableClass err  -- Neither anyclass nor stock work
 
   | otherwise
-  = DerivableViaInstance   -- DeriveAnyClass should work
+  = CanDeriveAnyClass   -- DeriveAnyClass should work
 
 classArgsErr :: Class -> [Type] -> SDoc
 classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
@@ -387,8 +565,8 @@ classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is n
 -- mechanism on certain classes (as opposed to classes that require
 -- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
 -- class for which stock deriving isn't possible.
-sideConditions :: DerivContext -> Class -> Maybe Condition
-sideConditions mtheta cls
+stockSideConditions :: DerivContext -> Class -> Maybe Condition
+stockSideConditions deriv_ctxt cls
   | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
   | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
   | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
@@ -397,7 +575,7 @@ sideConditions mtheta cls
   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
   | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
-                                           cond_std `andCond`
+                                           cond_vanilla `andCond`
                                            cond_args cls)
   | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
                                            cond_vanilla `andCond`
@@ -422,10 +600,10 @@ sideConditions mtheta cls
   | otherwise                      = Nothing
   where
     cls_key = getUnique cls
-    cond_std     = cond_stdOK mtheta False  -- Vanilla data constructors, at least one,
-                                            --    and monotype arguments
-    cond_vanilla = cond_stdOK mtheta True   -- Vanilla data constructors but
-                                            --   allow no data cons or polytype arguments
+    cond_std     = cond_stdOK deriv_ctxt False
+      -- Vanilla data constructors, at least one, and monotype arguments
+    cond_vanilla = cond_stdOK deriv_ctxt True
+      -- Vanilla data constructors but allow no data cons or polytype arguments
 
 canDeriveAnyClass :: DynFlags -> Validity
 -- IsValid: we can (try to) derive it via an empty instance declaration
@@ -436,49 +614,108 @@ canDeriveAnyClass dflags
   | otherwise
   = IsValid   -- OK!
 
-type Condition = DynFlags -> TyCon -> Validity
-        -- TyCon is the *representation* tycon if the data type is an indexed one
-        -- Nothing => OK
+type Condition
+   = DynFlags
+
+  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the
+              -- family 'TyCon'.
+
+  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.
+              -- Otherwise, this is the same as the other 'TyCon' argument.
+
+  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
+              -- possible. Otherwise, it's @'NotValid' err@, where @err@
+              -- explains what went wrong.
 
 orCond :: Condition -> Condition -> Condition
-orCond c1 c2 dflags tc
-  = case (c1 dflags tc, c2 dflags tc) of
+orCond c1 c2 dflags tc rep_tc
+  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
      (IsValid,    _)          -> IsValid    -- c1 succeeds
      (_,          IsValid)    -> IsValid    -- c21 succeeds
      (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
                                             -- Both fail
 
 andCond :: Condition -> Condition -> Condition
-andCond c1 c2 dflags tc = c1 dflags tc `andValid` c2 dflags tc
-
-cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not;
-                           --     if standalone, we just say "yes, go for it"
-           -> Bool         -- True <=> permissive: allow higher rank
-                           --          args and no data constructors
-           -> Condition
-cond_stdOK (Just _) _ _ _
-  = IsValid     -- Don't check these conservative conditions for
+andCond c1 c2 dflags tc rep_tc
+  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
+
+-- | Some common validity checks shared among stock derivable classes. One
+-- check that absolutely must hold is that if an instance @C (T a)@ is being
+-- derived, then @T@ must be a tycon for a data type or a newtype. The
+-- remaining checks are only performed if using a @deriving@ clause (i.e.,
+-- they're ignored if using @StandaloneDeriving@):
+--
+-- 1. The data type must have at least one constructor (this check is ignored
+--    if using @EmptyDataDeriving@).
+--
+-- 2. The data type cannot have any GADT constructors.
+--
+-- 3. The data type cannot have any constructors with existentially quantified
+--    type variables.
+--
+-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
+--
+-- 5. The data type cannot have fields with higher-rank types.
+cond_stdOK
+  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
+                  -- user-supplied context, 'InferContext' if not.
+                  -- If it is the former, we relax some of the validity checks
+                  -- we would otherwise perform (i.e., "just go for it").
+
+  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
+                  -- types (with no data constructors) even in the absence of
+                  -- the -XEmptyDataDeriving extension.
+
+  -> Condition
+cond_stdOK deriv_ctxt permissive dflags tc rep_tc
+  = valid_ADT `andValid` valid_misc
+  where
+    valid_ADT, valid_misc :: Validity
+    valid_ADT
+      | isAlgTyCon tc || isDataFamilyTyCon tc
+      = IsValid
+      | otherwise
+        -- Complain about functions, primitive types, and other tycons that
+        -- stock deriving can't handle.
+      = NotValid $ text "The last argument of the instance must be a"
+               <+> text "data or newtype application"
+
+    valid_misc
+      = case deriv_ctxt of
+         SupplyContext _ -> IsValid
+                -- Don't check these conservative conditions for
                 -- standalone deriving; just generate the code
                 -- and let the typechecker handle the result
-cond_stdOK Nothing permissive _ rep_tc
-  | null data_cons
-  , not permissive      = NotValid (no_cons_why rep_tc $$ suggestion)
-  | not (null con_whys) = NotValid (vcat con_whys $$ suggestion)
-  | otherwise           = IsValid
-  where
-    suggestion = text "Possible fix: use a standalone deriving declaration instead"
+         InferContext wildcard
+           | null data_cons -- 1.
+           , not permissive
+           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
+              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
+           | not (null con_whys)
+           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)
+           | otherwise
+           -> IsValid
+
+    empty_data_suggestion =
+      text "Use EmptyDataDeriving to enable deriving for empty data types"
+    possible_fix_suggestion wildcard
+      = case wildcard of
+          Just _ ->
+            text "Possible fix: fill in the wildcard constraint yourself"
+          Nothing ->
+            text "Possible fix: use a standalone deriving declaration instead"
     data_cons  = tyConDataCons rep_tc
     con_whys   = getInvalids (map check_con data_cons)
 
     check_con :: DataCon -> Validity
     check_con con
-      | not (null eq_spec)
+      | not (null eq_spec) -- 2.
       = bad "is a GADT"
-      | not (null ex_tvs)
+      | not (null ex_tvs) -- 3.
       = bad "has existential type variables in its type"
-      | not (null theta)
+      | not (null theta) -- 4.
       = bad "has constraints in its type"
-      | not (permissive || all isTauTy (dataConOrigArgTys con))
+      | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.
       = bad "has a higher-rank type"
       | otherwise
       = IsValid
@@ -491,10 +728,10 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
                      text "must have at least one data constructor"
 
 cond_RepresentableOk :: Condition
-cond_RepresentableOk _ tc = canDoGenerics tc
+cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc
 
 cond_Representable1Ok :: Condition
-cond_Representable1Ok _ tc = canDoGenerics1 tc
+cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc
 
 cond_enumOrProduct :: Class -> Condition
 cond_enumOrProduct cls = cond_isEnumeration `orCond`
@@ -503,13 +740,13 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
 cond_args :: Class -> Condition
 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 -- by generating specialised code.  For others (eg Data) we don't.
-cond_args cls _ tc
+cond_args cls _ _ rep_tc
   = case bad_args of
       []     -> IsValid
       (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
                              2 (text "for type" <+> quotes (ppr ty)))
   where
-    bad_args = [ arg_ty | con <- tyConDataCons tc
+    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
                         , arg_ty <- dataConOrigArgTys con
                         , isUnliftedType arg_ty
                         , not (ok_ty arg_ty) ]
@@ -527,7 +764,7 @@ cond_args cls _ tc
 
 
 cond_isEnumeration :: Condition
-cond_isEnumeration _ rep_tc
+cond_isEnumeration _ _ rep_tc
   | isEnumerationTyCon rep_tc = IsValid
   | otherwise                 = NotValid why
   where
@@ -537,7 +774,7 @@ cond_isEnumeration _ rep_tc
                   -- See Note [Enumeration types] in TyCon
 
 cond_isProduct :: Condition
-cond_isProduct _ rep_tc
+cond_isProduct _ _ rep_tc
   | isProductTyCon rep_tc = IsValid
   | otherwise             = NotValid why
   where
@@ -551,7 +788,7 @@ cond_functorOK :: Bool -> Bool -> Condition
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) optionally: don't use function types
 --            (e) no "stupid context" on data type
-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
   | null tc_tvs
   = NotValid (text "Data type" <+> quotes (ppr rep_tc)
               <+> text "must have some type parameters")
@@ -600,7 +837,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ rep_tc
     wrong_arg   = text "must use the type variable only as the last argument of a data type"
 
 checkFlag :: LangExt.Extension -> Condition
-checkFlag flag dflags _
+checkFlag flag dflags _ _
   | xopt flag dflags = IsValid
   | otherwise        = NotValid why
   where
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 12f8a1df4f..8f4e1076ca 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -18,23 +18,23 @@ module TcEnv(
         tcExtendGlobalEnv, tcExtendTyConEnv,
         tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
-        tcLookupLocatedGlobal, tcLookupGlobal,
+        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
         tcLookupTyCon, tcLookupClass,
         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupAxiom,
-        lookupGlobal,
+        lookupGlobal, ioLookupDataCon,
 
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnvList,
-        tcExtendTyVarEnv, tcExtendTyVarEnv2,
+        tcExtendTyVarEnv, tcExtendNameTyVarEnv,
         tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
-        tcExtendIdBndrs, tcExtendLocalTypeEnv,
+        tcExtendBinderStack, tcExtendLocalTypeEnv,
         isTypeClosedLetBndr,
 
         tcLookup, tcLookupLocated, tcLookupLocalIds,
-        tcLookupId, tcLookupTyVar,
+        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
         tcLookupLcl_maybe,
         getInLocalScope,
         wrongThingErr, pprBinders,
@@ -43,6 +43,9 @@ module TcEnv(
         getTypeSigNames,
         tcExtendRecEnv,         -- For knot-tying
 
+        -- Tidying
+        tcInitTidyEnv, tcInitOpenTidyEnv,
+
         -- Instances
         tcLookupInstance, tcGetInstEnvs,
 
@@ -68,6 +71,8 @@ module TcEnv(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import IfaceEnv
 import TcRnMonad
@@ -85,6 +90,7 @@ import DataCon ( DataCon )
 import PatSyn  ( PatSyn )
 import ConLike
 import TyCon
+import Type
 import CoAxiom
 import Class
 import Name
@@ -100,13 +106,14 @@ import Outputable
 import Encoding
 import FastString
 import ListSetOps
+import ErrUtils
 import Util
 import Maybes( MaybeErr(..), orElse )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.IORef
 import Data.List
-
+import Control.Monad
 
 {- *********************************************************************
 *                                                                      *
@@ -115,14 +122,69 @@ import Data.List
 ********************************************************************* -}
 
 lookupGlobal :: HscEnv -> Name -> IO TyThing
--- An IO version, used outside the typechecker
--- It's more complicated than it looks, because it may
--- need to suck in an interface file
+-- A variant of lookupGlobal_maybe for the clients which are not
+-- interested in recovering from lookup failure and accept panic.
 lookupGlobal hsc_env name
-  = initTcForLookup hsc_env (tcLookupGlobal name)
-    -- This initTcForLookup stuff is massive overkill
-    -- but that's how it is right now, and at least
-    -- this function localises it
+  = do  {
+          mb_thing <- lookupGlobal_maybe hsc_env name
+        ; case mb_thing of
+            Succeeded thing -> return thing
+            Failed msg      -> pprPanic "lookupGlobal" msg
+        }
+
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- This may look up an Id that one one has previously looked up.
+-- If so, we are going to read its interface file, and add its bindings
+-- to the ExternalPackageTable.
+lookupGlobal_maybe hsc_env name
+  = do  {    -- Try local envt
+          let mod = icInteractiveModule (hsc_IC hsc_env)
+              dflags = hsc_dflags hsc_env
+              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+
+        ; if nameIsLocalOrFrom tcg_semantic_mod name
+              then (return
+                (Failed (text "Can't find local name: " <+> ppr name)))
+                  -- Internal names can happen in GHCi
+              else
+           -- Try home package table and external package table
+          lookupImported_maybe hsc_env name
+        }
+
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+lookupImported_maybe hsc_env name
+  = do  { mb_thing <- lookupTypeHscEnv hsc_env name
+        ; case mb_thing of
+            Just thing -> return (Succeeded thing)
+            Nothing    -> importDecl_maybe hsc_env name
+            }
+
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+importDecl_maybe hsc_env name
+  | Just thing <- wiredInNameTyThing_maybe name
+  = do  { when (needWiredInHomeIface thing)
+               (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+                -- See Note [Loading instances for wired-in things]
+        ; return (Succeeded thing) }
+  | otherwise
+  = initIfaceLoad hsc_env (importDecl name)
+
+ioLookupDataCon :: HscEnv -> Name -> IO DataCon
+ioLookupDataCon hsc_env name = do
+  mb_thing <- ioLookupDataCon_maybe hsc_env name
+  case mb_thing of
+    Succeeded thing -> return thing
+    Failed msg      -> pprPanic "lookupDataConIO" msg
+
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
+ioLookupDataCon_maybe hsc_env name = do
+    thing <- lookupGlobal hsc_env name
+    return $ case thing of
+        AConLike (RealDataCon con) -> Succeeded con
+        _                          -> Failed $
+          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
+                text "used as a data constructor"
 
 {-
 ************************************************************************
@@ -167,6 +229,15 @@ tcLookupGlobal name
             Failed msg      -> failWithTc msg
         }}}
 
+-- Look up only in this module's global env't. Don't look in imports, etc.
+-- Panic if it's not there.
+tcLookupGlobalOnly :: Name -> TcM TyThing
+tcLookupGlobalOnly name
+  = do { env <- getGblEnv
+       ; return $ case lookupNameEnv (tcg_type_env env) name of
+                    Just thing -> thing
+                    Nothing    -> pprPanic "tcLookupGlobalOnly" (ppr name) }
+
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon name = do
     thing <- tcLookupGlobal name
@@ -268,7 +339,7 @@ setGlobalTypeEnv tcg_env new_type_env
 
 tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
   -- Just extend the global environment with some TyThings
-  -- Do not extend tcg_tcs etc
+  -- Do not extend tcg_tcs, tcg_patsyns etc
 tcExtendGlobalEnvImplicit things thing_inside
    = do { tcg_env <- getGblEnv
         ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
@@ -346,11 +417,18 @@ tcLookupId :: Name -> TcM Id
 --
 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
 tcLookupId name = do
-    thing <- tcLookup name
+    thing <- tcLookupIdMaybe name
     case thing of
-        ATcId { tct_id = id} -> return id
-        AGlobal (AnId id)    -> return id
-        _                    -> pprPanic "tcLookupId" (ppr name)
+        Just id -> return id
+        _       -> pprPanic "tcLookupId" (ppr name)
+
+tcLookupIdMaybe :: Name -> TcM (Maybe Id)
+tcLookupIdMaybe name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATcId { tct_id = id} -> return $ Just id
+           AGlobal (AnId id)    -> return $ Just id
+           _                    -> return Nothing }
 
 tcLookupLocalIds :: [Name] -> TcM [TcId]
 -- We expect the variables to all be bound, and all at
@@ -373,7 +451,7 @@ tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
 --      ATcTyCon or APromotionErr
 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
 tcExtendKindEnvList things thing_inside
-  = do { traceTc "txExtendKindEnvList" (ppr things)
+  = do { traceTc "tcExtendKindEnvList" (ppr things)
        ; updLclEnv upd_env thing_inside }
   where
     upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
@@ -381,40 +459,36 @@ tcExtendKindEnvList things thing_inside
 tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
 -- A variant of tcExtendKindEvnList
 tcExtendKindEnv extra_env thing_inside
-  = do { traceTc "txExtendKindEnv" (ppr extra_env)
+  = do { traceTc "tcExtendKindEnv" (ppr extra_env)
        ; updLclEnv upd_env thing_inside }
   where
     upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
 
 -----------------------
 -- Scoped type and kind variables
+-- Before using this function, consider using TcHsType.scopeTyVars, which
+-- bumps the TcLevel and thus prevents any of these TyVars from appearing
+-- in kinds of tyvars in an outer scope.
+-- Indeed, you should always use scopeTyVars unless some other code nearby
+-- bumps the TcLevel.
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
-  = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside
+  = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
 
-tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 binds thing_inside
+-- Before using this function, consider using TcHsType.scopeTyVars2, which
+-- bumps the TcLevel and thus prevents any of these TyVars from appearing
+-- in kinds of tyvars in an outer scope.
+tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
+tcExtendNameTyVarEnv binds thing_inside
   -- this should be used only for explicitly mentioned scoped variables.
   -- thus, no coercion variables
   = do { tc_extend_local_env NotTopLevel
                     [(name, ATyVar name tv) | (name, tv) <- binds] $
-         do { env <- getLclEnv
-            ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
-            ; setLclEnv env' thing_inside }}
+         tcExtendBinderStack tv_binds $
+         thing_inside }
   where
-    add_tidy_tvs env = foldl add env binds
-
-    -- We initialise the "tidy-env", used for tidying types before printing,
-    -- by building a reverse map from the in-scope type variables to the
-    -- OccName that the programmer originally used for them
-    add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv
-    add (env,subst) (name, tyvar)
-        = ASSERT( isTyVar tyvar )
-          case tidyOccName env (nameOccName name) of
-            (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
-                where
-                  tyvar' = setTyVarName tyvar name'
-                  name'  = tidyNameOcc name occ'
+    tv_binds :: [TcBinder]
+    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
 
 isTypeClosedLetBndr :: Id -> Bool
 -- See Note [Bindings with closed types] in TcRnTypes
@@ -423,7 +497,7 @@ isTypeClosedLetBndr = noFreeVarsOfType . idType
 tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
 -- Used for binding the recurive uses of Ids in a binding
 -- both top-level value bindings and and nested let/where-bindings
--- Does not extend the TcIdBinderStack
+-- Does not extend the TcBinderStack
 tcExtendRecIds pairs thing_inside
   = tc_extend_local_env NotTopLevel
           [ (name, ATcId { tct_id   = let_id
@@ -433,7 +507,7 @@ tcExtendRecIds pairs thing_inside
 
 tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
 -- Used for binding the Ids that have a complete user type signature
--- Does not extend the TcIdBinderStack
+-- Does not extend the TcBinderStack
 tcExtendSigIds top_lvl sig_ids thing_inside
   = tc_extend_local_env top_lvl
           [ (idName id, ATcId { tct_id   = id
@@ -447,10 +521,10 @@ tcExtendSigIds top_lvl sig_ids thing_inside
 tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
                   -> [TcId] -> TcM a -> TcM a
 -- Used for both top-level value bindings and and nested let/where-bindings
--- Adds to the TcIdBinderStack too
+-- Adds to the TcBinderStack too
 tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
                ids thing_inside
-  = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
+  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
     tc_extend_local_env top_lvl
           [ (idName id, ATcId { tct_id   = id
                               , tct_info = mk_tct_info id })
@@ -468,7 +542,7 @@ tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
 
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
 -- For lambda-bound and case-bound Ids
--- Extends the the TcIdBinderStack as well
+-- Extends the TcBinderStack as well
 tcExtendIdEnv ids thing_inside
   = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
 
@@ -479,8 +553,8 @@ tcExtendIdEnv1 name id thing_inside
 
 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 tcExtendIdEnv2 names_w_ids thing_inside
-  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
-                    | (_,mono_id) <- names_w_ids ] $
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | (_,mono_id) <- names_w_ids ] $
     tc_extend_local_env NotTopLevel
             [ (name, ATcId { tct_id = id
                            , tct_info    = NotLetBound })
@@ -502,7 +576,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
 -- The second argument of type TyVarSet is a set of type variables
 -- that are bound together with extra_env and should not be regarded
 -- as free in the types of extra_env.
-  = do  { traceTc "env2" (ppr extra_env)
+  = do  { traceTc "tc_extend_local_env" (ppr extra_env)
         ; env0 <- getLclEnv
         ; env1 <- tcExtendLocalTypeEnv env0 extra_env
         ; stage <- getStage
@@ -536,11 +610,19 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
 
     get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
       = case closed of
-          ClosedLet ->
-            ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs
-          _           ->
-            tvs `unionVarSet` id_tvs
-        where id_tvs = tyCoVarsOfType (idType id)
+          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )
+                       tvs
+          _other    -> tvs `unionVarSet` id_tvs
+        where
+           id_ty          = idType id
+           id_tvs         = tyCoVarsOfType id_ty
+           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)
+           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))
+           -- We only care about being closed wrt /type/ variables
+           -- E.g. a top-level binding might have a type like
+           --          foo :: t |> co
+           -- where co :: * ~ *
+           -- or some other as-yet-unsolved kind coercion
 
     get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
       = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
@@ -560,15 +642,51 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
         --
         -- Nor must we generalise g over any kind variables free in r's kind
 
--------------------------------------------------------------
--- Extending the TcIdBinderStack, used only for error messages
 
-tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
-tcExtendIdBndrs bndrs thing_inside
-  = do { traceTc "tcExtendIdBndrs" (ppr bndrs)
+{- *********************************************************************
+*                                                                      *
+             The TcBinderStack
+*                                                                      *
+********************************************************************* -}
+
+tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
+tcExtendBinderStack bndrs thing_inside
+  = do { traceTc "tcExtendBinderStack" (ppr bndrs)
        ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
                    thing_inside }
 
+tcInitTidyEnv :: TcM TidyEnv
+-- We initialise the "tidy-env", used for tidying types before printing,
+-- by building a reverse map from the in-scope type variables to the
+-- OccName that the programmer originally used for them
+tcInitTidyEnv
+  = do  { lcl_env <- getLclEnv
+        ; go emptyTidyEnv (tcl_bndrs lcl_env) }
+  where
+    go (env, subst) []
+      = return (env, subst)
+    go (env, subst) (b : bs)
+      | TcTvBndr name tyvar <- b
+       = do { let (env', occ') = tidyOccName env (nameOccName name)
+                  name'  = tidyNameOcc name occ'
+                  tyvar1 = setTyVarName tyvar name'
+            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
+              -- Be sure to zonk here!  Tidying applies to zonked
+              -- types, so if we don't zonk we may create an
+              -- ill-kinded type (Trac #14175)
+            ; go (env', extendVarEnv subst tyvar tyvar2) bs }
+      | otherwise
+      = go (env, subst) bs
+
+-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
+-- type. Useful when tidying open types.
+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
+tcInitOpenTidyEnv tvs
+  = do { env1 <- tcInitTidyEnv
+       ; let env2 = tidyFreeTyCoVars env1 tvs
+       ; return env2 }
+
+
 
 {- *********************************************************************
 *                                                                      *
@@ -590,10 +708,18 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
     get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
     get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
       = concatMap (get_fi_cons . unLoc) fids
+    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"
+    get_cons (L _ (XInstDecl _)) = panic "get_cons"
 
     get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
-    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
       = map unLoc $ concatMap (getConNames . unLoc) cons
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = XHsDataDefn _ }}})
+      = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"
 
 
 tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
@@ -611,8 +737,8 @@ getTypeSigNames sigs
     get_type_sig :: LSig GhcRn -> NameSet -> NameSet
     get_type_sig sig ns =
       case sig of
-        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
-        L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
+        L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
+        L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
         _ -> ns
 
 
@@ -791,7 +917,7 @@ default the 'a' to (), rather than to Integer (which is what would otherwise hap
 and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
 () to the list of defaulting types.  See Trac #1200.
 
-Additonally, the list type [] is added as a default specialization for
+Additionally, the list type [] is added as a default specialization for
 Traversable and Foldable. As such the default default list now has types of
 varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).
 
@@ -846,10 +972,12 @@ data InstBindings a
            --          Used only to improve error messages
       }
 
-instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where
+instance (OutputableBndrId (GhcPass a))
+       => Outputable (InstInfo (GhcPass a)) where
     ppr = pprInstInfoDetails
 
-pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc
+pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
+                   => InstInfo (GhcPass a) -> SDoc
 pprInstInfoDetails info
    = hang (pprInstanceHdr (iSpec info) <+> text "where")
         2 (details (iBinds info))
diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot
index 8cc90ae5a0..5e9bfe2039 100644
--- a/compiler/typecheck/TcEnv.hs-boot
+++ b/compiler/typecheck/TcEnv.hs-boot
@@ -1,7 +1,10 @@
-{-
->module TcEnv where
->import TcRnTypes
->import HsExtension ( GhcTcId, IdP )
->
->tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
--}
+module TcEnv where
+
+import TcRnTypes( TcM )
+import VarEnv( TidyEnv )
+
+-- Annoyingly, there's a recursion between tcInitTidyEnv
+-- (which does zonking and hence needs TcMType) and
+-- addErrTc etc which live in TcRnMonad.  Rats.
+tcInitTidyEnv :: TcM TidyEnv
+
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index ed1eb82ce6..6827a58f55 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -9,15 +9,17 @@ module TcErrors(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes
 import TcRnMonad
 import TcMType
 import TcUnify( occCheckForErrors, OccCheckResult(..) )
+import TcEnv( tcInitTidyEnv )
 import TcType
 import RnUnbound ( unknownNameSuggestions )
 import Type
 import TyCoRep
-import Kind
 import Unify            ( tcMatchTys )
 import Module
 import FamInst
@@ -28,13 +30,13 @@ import TyCon
 import Class
 import DataCon
 import TcEvidence
+import TcEvTerm
 import HsExpr  ( UnboundVar(..) )
 import HsBinds ( PatSynBind(..) )
 import Name
 import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
-               , mkRdrUnqual, isLocalGRE, greSrcSpan, pprNameProvenance
-               , GlobalRdrElt (..), globalRdrEnvElts )
-import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey )
+               , mkRdrUnqual, isLocalGRE, greSrcSpan )
+import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey, tYPETyConKey )
 import Id
 import Var
 import VarSet
@@ -43,27 +45,27 @@ import NameSet
 import Bag
 import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )
 import BasicTypes
-import ConLike          ( ConLike(..), conLikeWrapId_maybe )
+import ConLike          ( ConLike(..))
 import Util
-import HscTypes (HscEnv, lookupTypeHscEnv, TypeEnv, lookupTypeEnv )
-import NameEnv (lookupNameEnv)
 import FastString
 import Outputable
 import SrcLoc
 import DynFlags
 import ListSetOps       ( equivClasses )
 import Maybes
+import Pair
 import qualified GHC.LanguageExtensions as LangExt
 import FV ( fvVarList, unionFV )
 
 import Control.Monad    ( when )
+import Data.Foldable    ( toList )
 import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
 import qualified Data.Set as Set
 
-#if __GLASGOW_HASKELL__ > 710
+import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
+
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
-#endif
 
 
 {-
@@ -123,7 +125,7 @@ reportUnsolved wanted
        ; defer_errors <- goptM Opt_DeferTypeErrors
        ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
        ; let type_errors | not defer_errors = TypeError
-                         | warn_errors      = TypeWarn
+                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)
                          | otherwise        = TypeDefer
 
        ; defer_holes <- goptM Opt_DeferTypedHoles
@@ -144,7 +146,7 @@ reportUnsolved wanted
                                 | warn_out_of_scope      = HoleWarn
                                 | otherwise              = HoleDefer
 
-       ; report_unsolved binds_var False type_errors expr_holes
+       ; report_unsolved binds_var type_errors expr_holes
           type_holes out_of_scope_holes wanted
 
        ; ev_binds <- getTcEvBindsMap binds_var
@@ -159,8 +161,8 @@ reportUnsolved wanted
 -- and for simplifyDefault.
 reportAllUnsolved :: WantedConstraints -> TcM ()
 reportAllUnsolved wanted
-  = do { ev_binds <- newTcEvBinds
-       ; report_unsolved ev_binds False TypeError
+  = do { ev_binds <- newNoTcEvBinds
+       ; report_unsolved ev_binds TypeError
                          HoleError HoleError HoleError wanted }
 
 -- | Report all unsolved goals as warnings (but without deferring any errors to
@@ -169,23 +171,27 @@ reportAllUnsolved wanted
 warnAllUnsolved :: WantedConstraints -> TcM ()
 warnAllUnsolved wanted
   = do { ev_binds <- newTcEvBinds
-       ; report_unsolved ev_binds True TypeWarn
+       ; report_unsolved ev_binds (TypeWarn NoReason)
                          HoleWarn HoleWarn HoleWarn wanted }
 
 -- | Report unsolved goals as errors or warnings.
 report_unsolved :: EvBindsVar        -- cec_binds
-                -> Bool              -- Errors as warnings
                 -> TypeErrorChoice   -- Deferred type errors
                 -> HoleChoice        -- Expression holes
                 -> HoleChoice        -- Type holes
                 -> HoleChoice        -- Out of scope holes
                 -> WantedConstraints -> TcM ()
-report_unsolved mb_binds_var err_as_warn type_errors expr_holes
+report_unsolved mb_binds_var type_errors expr_holes
     type_holes out_of_scope_holes wanted
   | isEmptyWC wanted
   = return ()
   | otherwise
-  = do { traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
+  = do { traceTc "reportUnsolved warning/error settings:" $
+           vcat [ text "type errors:" <+> ppr type_errors
+                , text "expr holes:" <+> ppr expr_holes
+                , text "type holes:" <+> ppr type_holes
+                , text "scope holes:" <+> ppr out_of_scope_holes ]
+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
 
        ; wanted <- zonkWC wanted   -- Zonk to reveal all information
        ; env0 <- tcInitTidyEnv
@@ -196,17 +202,22 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes
 
        ; traceTc "reportUnsolved (after zonking):" $
          vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
+              , text "Tidy env:" <+> ppr tidy_env
               , text "Wanted:" <+> ppr wanted ]
 
        ; warn_redundant <- woptM Opt_WarnRedundantConstraints
        ; let err_ctxt = CEC { cec_encl  = []
                             , cec_tidy  = tidy_env
                             , cec_defer_type_errors = type_errors
-                            , cec_errors_as_warns = err_as_warn
                             , cec_expr_holes = expr_holes
                             , cec_type_holes = type_holes
                             , cec_out_of_scope_holes = out_of_scope_holes
-                            , cec_suppress = False -- See Note [Suppressing error messages]
+                            , cec_suppress = insolubleWC wanted
+                                 -- See Note [Suppressing error messages]
+                                 -- Suppress low-priority errors if there
+                                 -- are insolule errors anywhere;
+                                 -- See Trac #15539 and c.f. setting ic_status
+                                 -- in TcSimplify.setImplicationStatus
                             , cec_warn_redundant = warn_redundant
                             , cec_binds    = mb_binds_var }
 
@@ -222,13 +233,13 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes
 data Report
   = Report { report_important :: [SDoc]
            , report_relevant_bindings :: [SDoc]
-           , report_valid_substitutions :: [SDoc]
+           , report_valid_hole_fits :: [SDoc]
            }
 
 instance Outputable Report where   -- Debugging only
   ppr (Report { report_important = imp
               , report_relevant_bindings = rel
-              , report_valid_substitutions = val })
+              , report_valid_hole_fits = val })
     = vcat [ text "important:" <+> vcat imp
            , text "relevant:"  <+> vcat rel
            , text "valid:"  <+> vcat val ]
@@ -241,20 +252,17 @@ idea is that the main msg ('report_important') varies depending on the error
 in question, but context and relevant bindings are always the same, which
 should simplify visual parsing.
 
-The context is added when the the Report is passed off to 'mkErrorReport'.
+The context is added when the Report is passed off to 'mkErrorReport'.
 Unfortunately, unlike the context, the relevant bindings are added in
 multiple places so they have to be in the Report.
 -}
 
-#if __GLASGOW_HASKELL__ > 710
 instance Semigroup Report where
     Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
-#endif
 
 instance Monoid Report where
     mempty = Report [] [] []
-    mappend (Report a1 b1 c1) (Report a2 b2 c2)
-      = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
+    mappend = (Semigroup.<>)
 
 -- | Put a doc into the important msgs block.
 important :: SDoc -> Report
@@ -264,13 +272,17 @@ important doc = mempty { report_important = [doc] }
 relevant_bindings :: SDoc -> Report
 relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
 
--- | Put a doc into the valid substitutions block.
-valid_substitutions :: SDoc -> Report
-valid_substitutions docs = mempty { report_valid_substitutions = [docs] }
+-- | Put a doc into the valid hole fits block.
+valid_hole_fits :: SDoc -> Report
+valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }
 
 data TypeErrorChoice   -- What to do for type errors found by the type checker
   = TypeError     -- A type error aborts compilation with an error message
-  | TypeWarn      -- A type error is deferred to runtime, plus a compile-time warning
+  | TypeWarn WarnReason
+                  -- A type error is deferred to runtime, plus a compile-time warning
+                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)
+                  -- but it isn't for the Safe Haskell Overlapping Instances warnings
+                  -- see warnAllUnsolved
   | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time
 
 data HoleChoice
@@ -284,9 +296,9 @@ instance Outputable HoleChoice where
   ppr HoleDefer = text "HoleDefer"
 
 instance Outputable TypeErrorChoice  where
-  ppr TypeError = text "TypeError"
-  ppr TypeWarn  = text "TypeWarn"
-  ppr TypeDefer = text "TypeDefer"
+  ppr TypeError         = text "TypeError"
+  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason
+  ppr TypeDefer         = text "TypeDefer"
 
 data ReportErrCtxt
     = CEC { cec_encl :: [Implication]  -- Enclosing implications
@@ -298,10 +310,6 @@ data ReportErrCtxt
                                        -- into warnings, and emit evidence bindings
                                        -- into 'cec_binds' for unsolved constraints
 
-          , cec_errors_as_warns :: Bool   -- Turn all errors into warnings
-                                          -- (except for Holes, which are
-                                          -- controlled by cec_type_holes and
-                                          -- cec_expr_holes)
           , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
 
           -- cec_expr_holes is a union of:
@@ -322,7 +330,6 @@ data ReportErrCtxt
 
 instance Outputable ReportErrCtxt where
   ppr (CEC { cec_binds              = bvar
-           , cec_errors_as_warns    = ew
            , cec_defer_type_errors  = dte
            , cec_expr_holes         = eh
            , cec_type_holes         = th
@@ -331,7 +338,6 @@ instance Outputable ReportErrCtxt where
            , cec_suppress           = sup })
     = text "CEC" <+> braces (vcat
          [ text "cec_binds"              <+> equals <+> ppr bvar
-         , text "cec_errors_as_warns"    <+> equals <+> ppr ew
          , text "cec_defer_type_errors"  <+> equals <+> ppr dte
          , text "cec_expr_holes"         <+> equals <+> ppr eh
          , text "cec_type_holes"         <+> equals <+> ppr th
@@ -339,9 +345,23 @@ instance Outputable ReportErrCtxt where
          , text "cec_warn_redundant"     <+> equals <+> ppr wr
          , text "cec_suppress"           <+> equals <+> ppr sup ])
 
-{-
-Note [Suppressing error messages]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
+deferringAnyBindings :: ReportErrCtxt -> Bool
+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred
+deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError
+                          , cec_expr_holes         = HoleError
+                          , cec_out_of_scope_holes = HoleError }) = False
+deferringAnyBindings _                                            = True
+
+-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings
+-- at all.
+noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
+noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError
+                               , cec_expr_holes         = HoleError
+                               , cec_out_of_scope_holes = HoleError }
+
+{- Note [Suppressing error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The cec_suppress flag says "don't report any errors".  Instead, just create
 evidence bindings (as usual).  It's used when more important errors have occurred.
 
@@ -351,13 +371,27 @@ Specifically (see reportWanteds)
   * If there are any insolubles (eg Int~Bool), here or in a nested implication,
     then suppress errors from the simple constraints here.  Sometimes the
     simple-constraint errors are a knock-on effect of the insolubles.
+
+This suppression behaviour is controlled by the Bool flag in
+ReportErrorSpec, as used in reportWanteds.
+
+But we need to take care: flags can turn errors into warnings, and we
+don't want those warnings to suppress subsequent errors (including
+suppressing the essential addTcEvBind for them: Trac #15152). So in
+tryReporter we use askNoErrs to see if any error messages were
+/actually/ produced; if not, we don't switch on suppression.
+
+A consequence is that warnings never suppress warnings, so turning an
+error into a warning may allow subsequent warnings to appear that were
+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)
 -}
 
 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
-reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
+reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
+                                 , ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
                                  , ic_status = status, ic_info = info
-                                 , ic_env = tcl_env, ic_tclvl = tc_lvl })
+                                 , ic_tclvl = tc_lvl })
   | BracketSkol <- info
   , not insoluble
   = return ()        -- For Template Haskell brackets report only
@@ -369,29 +403,44 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
   = do { traceTc "reportImplic" (ppr implic')
        ; reportWanteds ctxt' tc_lvl wanted
        ; when (cec_warn_redundant ctxt) $
-         warnRedundantConstraints ctxt' tcl_env info' dead_givens }
+         warnRedundantConstraints ctxt' tcl_env info' dead_givens
+       ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
   where
+    tcl_env      = implicLclEnv implic
     insoluble    = isInsolubleStatus status
-    (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
     info'        = tidySkolemInfo env1 info
     implic' = implic { ic_skols = tvs'
                      , ic_given = map (tidyEvVar env1) given
                      , ic_info  = info' }
-    ctxt' = ctxt { cec_tidy     = env1
-                 , cec_encl     = implic' : cec_encl ctxt
-
-                 , cec_suppress = insoluble || cec_suppress ctxt
-                      -- Suppress inessential errors if there
-                      -- are are insolubles anywhere in the
-                      -- tree rooted here, or we've come across
-                      -- a suppress-worthy constraint higher up (Trac #11541)
-
-                 , cec_binds    = evb }
+    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt
+          | otherwise                = ctxt
+          -- If we go inside an implication that has no term
+          -- evidence (e.g. unifying under a forall), we can't defer
+          -- type errors.  You could imagine using the /enclosing/
+          -- bindings (in cec_binds), but that may not have enough stuff
+          -- in scope for the bindings to be well typed.  So we just
+          -- switch off deferred type errors altogether.  See Trac #14605.
+
+    ctxt' = ctxt1 { cec_tidy     = env1
+                  , cec_encl     = implic' : cec_encl ctxt
+
+                  , cec_suppress = insoluble || cec_suppress ctxt
+                        -- Suppress inessential errors if there
+                        -- are insolubles anywhere in the
+                        -- tree rooted here, or we've come across
+                        -- a suppress-worthy constraint higher up (Trac #11541)
+
+                  , cec_binds    = evb }
 
     dead_givens = case status of
                     IC_Solved { ics_dead = dead } -> dead
                     _                             -> []
 
+    bad_telescope = case status of
+              IC_BadTelescope -> True
+              _               -> False
+
 warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
 -- See Note [Tracking redundant constraints] in TcSimplify
 warnRedundantConstraints ctxt env info ev_vars
@@ -415,12 +464,31 @@ warnRedundantConstraints ctxt env info ev_vars
    doc = text "Redundant constraint" <> plural redundant_evs <> colon
          <+> pprEvVarTheta redundant_evs
 
-   redundant_evs = case info of -- See Note [Redundant constraints in instance decls]
-                     InstSkol -> filterOut improving ev_vars
-                     _        -> ev_vars
+   redundant_evs =
+       filterOut is_type_error $
+       case info of -- See Note [Redundant constraints in instance decls]
+         InstSkol -> filterOut (improving . idType) ev_vars
+         _        -> ev_vars
 
-   improving ev_var = any isImprovementPred $
-                      transSuperClasses (idType ev_var)
+   -- See #15232
+   is_type_error = isJust . userTypeError_maybe . idType
+
+   improving pred -- (transSuperClasses p) does not include p
+     = any isImprovementPred (pred : transSuperClasses pred)
+
+reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
+reportBadTelescope ctxt env (Just telescope) skols
+  = do { msg <- mkErrorReport ctxt env (important doc)
+       ; reportError msg }
+  where
+    doc = hang (text "These kind and type variables:" <+> telescope $$
+                text "are out of dependency order. Perhaps try this ordering:")
+             2 (pprTyVars sorted_tvs)
+
+    sorted_tvs = toposortTyVars skols
+
+reportBadTelescope _ _ Nothing skols
+  = pprPanic "reportBadTelescope" (ppr skols)
 
 {- Note [Redundant constraints in instance decls]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -440,11 +508,10 @@ This only matters in instance declarations..
 -}
 
 reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
-reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
+reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
   = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
-                                       , text "Insols =" <+> ppr insols
                                        , text "Suppress =" <+> ppr (cec_suppress ctxt)])
-       ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples))
+       ; traceTc "rw2" (ppr tidy_cts)
 
          -- First deal with things that are utterly wrong
          -- Like Int ~ Bool (incl nullary TyCons)
@@ -471,26 +538,31 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
             -- if there's a *given* insoluble here (= inaccessible code)
  where
     env = cec_tidy ctxt
+    tidy_cts = bagToList (mapBag (tidyCt env) simples)
 
     -- report1: ones that should *not* be suppresed by
     --          an insoluble somewhere else in the tree
     -- It's crucial that anything that is considered insoluble
-    -- (see TcRnTypes.trulyInsoluble) is caught here, otherwise
+    -- (see TcRnTypes.insolubleWantedCt) is caught here, otherwise
     -- we might suppress its error message, and proceed on past
     -- type checking to get a Lint error later
-    report1 = [ ("custom_error", is_user_type_error,
-                                                  True, mkUserTypeErrorReporter)
+    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)
+              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)
+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)
+
               , given_eq_spec
-              , ("insoluble2",   utterly_wrong,   True, mkGroupReporter mkEqErr)
-              , ("skolem eq1",   very_wrong,      True, mkSkolReporter)
-              , ("skolem eq2",   skolem_eq,       True, mkSkolReporter)
-              , ("non-tv eq",    non_tv_eq,       True, mkSkolReporter)
-              , ("Out of scope", is_out_of_scope, True, mkHoleReporter)
-              , ("Holes",        is_hole,         False, mkHoleReporter)
+              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)
+              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)
+              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)
+              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)
 
                   -- The only remaining equalities are alpha ~ ty,
                   -- where alpha is untouchable; and representational equalities
-              , ("Other eqs",    is_equality,     False, mkGroupReporter mkEqErr) ]
+                  -- Prefer homogeneous equalities over hetero, because the
+                  -- former might be holding up the latter.
+                  -- See Note [Equalities with incompatible kinds] in TcCanonical
+              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)
+              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]
 
     -- report2: we suppress these if there are insolubles elsewhere in the tree
     report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)
@@ -527,6 +599,9 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
 
     is_user_type_error ct _ = isUserTypeErrorCt ct
 
+    is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2
+    is_homo_equality _ _                  = False
+
     is_equality _ (EqPred {}) = True
     is_equality _ _           = False
 
@@ -539,22 +614,28 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
     is_irred _ (IrredPred {}) = True
     is_irred _ _              = False
 
-    given_eq_spec = case find_gadt_match (cec_encl ctxt) of
-       Just imp -> ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter imp)
-       Nothing  -> ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
-                  -- False means don't suppress subsequent errors
-                  -- Reason: we don't report all given errors
-                  --         (see mkGivenErrorReporter), and we should only suppress
-                  --         subsequent errors if we actually report this one!
-                  --         Trac #13446 is an example
-
-    find_gadt_match [] = Nothing
-    find_gadt_match (implic : implics)
+    given_eq_spec  -- See Note [Given errors]
+      | has_gadt_match (cec_encl ctxt)
+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
+      | otherwise
+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
+          -- False means don't suppress subsequent errors
+          -- Reason: we don't report all given errors
+          --         (see mkGivenErrorReporter), and we should only suppress
+          --         subsequent errors if we actually report this one!
+          --         Trac #13446 is an example
+
+    -- See Note [Given errors]
+    has_gadt_match [] = False
+    has_gadt_match (implic : implics)
       | PatSkol {} <- ic_info implic
       , not (ic_no_eqs implic)
-      = Just implic
+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
+          -- Don't bother doing this if -Winaccessible-code isn't enabled.
+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
+      = True
       | otherwise
-      = find_gadt_match implics
+      = has_gadt_match implics
 
 ---------------
 isSkolemTy :: TcLevel -> Type -> Bool
@@ -562,8 +643,8 @@ isSkolemTy :: TcLevel -> Type -> Bool
 isSkolemTy tc_lvl ty
   | Just tv <- getTyVar_maybe ty
   =  isSkolemTyVar tv
-  || (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)
-     -- The last case is for touchable SigTvs
+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
+     -- The last case is for touchable TyVarTvs
      -- we postpone untouchables to a latter test (too obscure)
 
   | otherwise
@@ -601,10 +682,10 @@ mkSkolReporter ctxt cts
        | eq_lhs_type   ct1 ct2 = True
        | otherwise             = False
 
-mkHoleReporter :: Reporter
+mkHoleReporter :: [Ct] -> Reporter
 -- Reports errors one at a time
-mkHoleReporter ctxt
-  = mapM_ $ \ct -> do { err <- mkHoleError ctxt ct
+mkHoleReporter tidy_simples ctxt
+  = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct
                       ; maybeReportHoleError ctxt ct err
                       ; maybeAddDeferredHoleBinding ctxt err ct }
 
@@ -623,14 +704,17 @@ mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
                             Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
 
 
-mkGivenErrorReporter :: Implication -> Reporter
+mkGivenErrorReporter :: Reporter
 -- See Note [Given errors]
-mkGivenErrorReporter implic ctxt cts
+mkGivenErrorReporter ctxt cts
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
        ; dflags <- getDynFlags
-       ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
+       ; let (implic:_) = cec_encl ctxt
+                 -- Always non-empty when mkGivenErrorReporter is called
+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
                    -- For given constraints we overwrite the env (and hence src-loc)
-                  -- with one from the implication.  See Note [Inaccessible code]
+                   -- with one from the immediately-enclosing implication.
+                   -- See Note [Inaccessible code]
 
              inaccessible_msg = hang (text "Inaccessible code in")
                                    2 (ppr (ic_info implic))
@@ -641,7 +725,7 @@ mkGivenErrorReporter implic ctxt cts
                              Nothing ty1 ty2
 
        ; traceTc "mkGivenErrorReporter" (ppr ct)
-       ; maybeReportError ctxt err }
+       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }
   where
     (ct : _ )  = cts    -- Never empty
     (ty1, ty2) = getEqPredTys (ctPred ct)
@@ -675,15 +759,15 @@ We'd like to point out that the T3 match is inaccessible. It
 will have a Given constraint [G] Int ~ Bool.
 
 But we don't want to report ALL insoluble Given constraints.  See Trac
-#12466 for a long discussion on.  For example, if we aren't careful
+#12466 for a long discussion.  For example, if we aren't careful
 we'll complain about
    f :: ((Int ~ Bool) => a -> a) -> Int
 which arguably is OK.  It's more debatable for
    g :: (Int ~ Bool) => Int -> Int
-but it's tricky to distinguish these cases to we don't report
+but it's tricky to distinguish these cases so we don't report
 either.
 
-The bottom line is this: find_gadt_match looks for an encosing
+The bottom line is this: has_gadt_match looks for an enclosing
 pattern match which binds some equality constraints.  If we
 find one, we report the insoluble Given.
 -}
@@ -694,7 +778,7 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
 -- Group together errors from same location,
 -- and report only the first (to avoid a cascade)
 mkGroupReporter mk_err ctxt cts
-  = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts)
+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
 
 eq_lhs_type :: Ct -> Ct -> Bool
 eq_lhs_type ct1 ct2
@@ -717,6 +801,10 @@ reportGroup mk_err ctxt cts =
                ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
 
         (_, cts') -> do { err <- mk_err ctxt cts'
+                        ; traceTc "About to maybeReportErr" $
+                          vcat [ text "Constraint:"             <+> ppr cts'
+                               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
+                               , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
                         ; maybeReportError ctxt err
                             -- But see Note [Always warn with -fdefer-type-errors]
                         ; traceTc "reportGroup" (ppr cts')
@@ -732,6 +820,8 @@ reportGroup mk_err ctxt cts =
             _otherwise           -> False
 
 maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
+-- Unlike maybeReportError, these "hole" errors are
+-- /not/ suppressed by cec_suppress.  We want to see them!
 maybeReportHoleError ctxt ct err
   -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
   -- generated for holes in partial type signatures.
@@ -772,25 +862,23 @@ maybeReportError ctxt err
   | cec_suppress ctxt    -- Some worse error has occurred;
   = return ()            -- so suppress this error/warning
 
-  | cec_errors_as_warns ctxt
-  = reportWarning NoReason err
-
   | otherwise
   = case cec_defer_type_errors ctxt of
-      TypeDefer -> return ()
-      TypeWarn  -> reportWarning (Reason Opt_WarnDeferredTypeErrors) err
-      TypeError -> reportError err
+      TypeDefer       -> return ()
+      TypeWarn reason -> reportWarning reason err
+      TypeError       -> reportError err
 
 addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
 -- See Note [Deferring coercion errors to runtime]
 addDeferredBinding ctxt err ct
-  | CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
+  | deferringAnyBindings ctxt
+  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
     -- Only add deferred bindings for Wanted constraints
   = do { dflags <- getDynFlags
        ; let err_msg = pprLocErrMsg err
              err_fs  = mkFastString $ showSDoc dflags $
                        err_msg $$ text "(deferred type error)"
-             err_tm  = EvDelayedError pred err_fs
+             err_tm  = evDelayedError pred err_fs
              ev_binds_var = cec_binds ctxt
 
        ; case dest of
@@ -798,9 +886,9 @@ addDeferredBinding ctxt err ct
              -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
            HoleDest hole
              -> do { -- See Note [Deferred errors for coercion holes]
-                     evar <- newEvVar pred
-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
-                   ; fillCoercionHole hole (mkTcCoVarCo evar) }}
+                     let co_var = coHoleCoVar hole
+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
 
   | otherwise   -- Do not set any evidence for Given/Derived
   = return ()
@@ -815,29 +903,37 @@ maybeAddDeferredHoleBinding ctxt err ct
 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 -- Use the first reporter in the list whose predicate says True
 tryReporters ctxt reporters cts
-  = do { traceTc "tryReporters {" (ppr cts)
-       ; (ctxt', cts') <- go ctxt reporters cts
+  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
+       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
+       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
        ; traceTc "tryReporters }" (ppr cts')
        ; return (ctxt', cts') }
   where
-    go ctxt [] cts
-      = return (ctxt, cts)
-
-    go ctxt (r : rs) cts
-      = do { (ctxt', cts') <- tryReporter ctxt r cts
-           ; go ctxt' rs cts' }
+    go ctxt [] vis_cts invis_cts
+      = return (ctxt, vis_cts ++ invis_cts)
+
+    go ctxt (r : rs) vis_cts invis_cts
+       -- always look at *visible* Origins before invisible ones
+       -- this is the whole point of isVisibleOrigin
+      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
+           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
+           ; go ctxt'' rs vis_cts' invis_cts' }
                 -- Carry on with the rest, because we must make
                 -- deferred bindings for them if we have -fdefer-type-errors
                 -- But suppress their error messages
 
 tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts
-  | null yeses = return (ctxt, cts)
-  | otherwise  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
-                    ; reporter ctxt yeses
-                    ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt }
-                    ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
-                    ; return (ctxt', nos) }
+  | null yeses
+  = return (ctxt, cts)
+  | otherwise
+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
+       ; let suppress_now = not no_errs && suppress_after
+                            -- See Note [Suppressing error messages]
+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
+       ; return (ctxt', nos) }
   where
     (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
 
@@ -894,9 +990,8 @@ getUserGivensFromImplics :: [Implication] -> [UserGiven]
 getUserGivensFromImplics implics
   = reverse (filterOut (null . ic_given) implics)
 
-{-
-Note [Always warn with -fdefer-type-errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Always warn with -fdefer-type-errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When -fdefer-type-errors is on we warn about *all* type errors, even
 if cec_suppress is on.  This can lead to a lot more warnings than you
 would get errors without -fdefer-type-errors, but if we suppress any of
@@ -924,9 +1019,9 @@ coercion.
 
 Note [Do not report derived but soluble errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The wc_simples include Derived constraints that have not been solved, but are
-not insoluble (in that case they'd be in wc_insols).  We do not want to report
-these as errors:
+The wc_simples include Derived constraints that have not been solved,
+but are not insoluble (in that case they'd be reported by 'report1').
+We do not want to report these as errors:
 
 * Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
   an unsolved [D] Eq a, and we do not want to report that; it's just noise.
@@ -990,8 +1085,8 @@ mkIrredErr ctxt cts
     (ct1:_) = cts
 
 ----------------
-mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
-mkHoleError _ctxt ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
+mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
+mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
   -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible
   -- in-scope variables in the message, and note inaccessible exact matches
   = do { dflags   <- getDynFlags
@@ -1053,7 +1148,7 @@ mkHoleError _ctxt ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
         th_end_ln   = srcSpanEndLine   th_loc
         is_th_bind = th_loc `containsSpan` bind_loc
 
-mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })
+mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
   -- Explicit holes, like "_" or "_f"
   = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
                -- The 'False' means "don't filter the bindings"; see Trac #8191
@@ -1064,16 +1159,20 @@ mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })
                   = givenConstraintsMsg ctxt
                | otherwise = empty
 
-       ; sub_msg <-  validSubstitutions ct
+       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits
+       ; (ctxt, sub_msg) <- if show_valid_hole_fits
+                            then validHoleFits ctxt tidy_simples ct
+                            else return (ctxt, empty)
        ; mkErrorMsgFromCt ctxt ct $
             important hole_msg `mappend`
             relevant_bindings (binds_msg $$ constraints_msg) `mappend`
-            valid_substitutions sub_msg}
+            valid_hole_fits sub_msg}
 
   where
-    occ     = holeOcc hole
-    hole_ty = ctEvPred (ctEvidence ct)
-    tyvars  = tyCoVarsOfTypeList hole_ty
+    occ       = holeOcc hole
+    hole_ty   = ctEvPred (ctEvidence ct)
+    hole_kind = typeKind hole_ty
+    tyvars    = tyCoVarsOfTypeList hole_ty
 
     hole_msg = case hole of
       ExprHole {} -> vcat [ hang (text "Found hole:")
@@ -1082,11 +1181,25 @@ mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })
       TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>
                                   quotes (ppr occ))
                                2 (text "standing for" <+>
-                                  quotes (pprType hole_ty))
+                                  quotes pp_hole_type_with_kind)
                           , tyvars_msg, type_hole_hint ]
 
+    pp_hole_type_with_kind
+      | isLiftedTypeKind hole_kind
+        || isCoercionType hole_ty -- Don't print the kind of unlifted
+                                  -- equalities (#15039)
+      = pprType hole_ty
+      | otherwise
+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind
+
     tyvars_msg = ppUnless (null tyvars) $
-                 text "Where:" <+> vcat (map loc_msg tyvars)
+                 text "Where:" <+> (vcat (map loc_msg other_tvs)
+                                    $$ pprSkols ctxt skol_tvs)
+       where
+         (skol_tvs, other_tvs) = partition is_skol tyvars
+         is_skol tv = isTcTyVar tv && isSkolemTyVar tv
+                      -- Coercion variables can be free in the
+                      -- hole, via kind casts
 
     type_hole_hint
          | HoleError <- cec_type_holes ctxt
@@ -1105,116 +1218,38 @@ mkHoleError ctxt ct@(CHoleCan { cc_hole = hole })
        | isTyVar tv
        = case tcTyVarDetails tv of
            MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
-           _         -> extraTyVarInfo ctxt tv
-       | otherwise
+           _         -> empty  -- Skolems dealt with already
+       | otherwise  -- A coercion variable can be free in the hole type
        = sdocWithDynFlags $ \dflags ->
          if gopt Opt_PrintExplicitCoercions dflags
          then quotes (ppr tv) <+> text "is a coercion variable"
          else empty
 
-mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
-
-
--- See Note [Valid substitutions include ...]
-validSubstitutions :: Ct -> TcM SDoc
-validSubstitutions ct | isExprHoleCt ct =
-  do { top_env <- getTopEnv
-     ; rdr_env <- getGlobalRdrEnv
-     ; gbl_env <- tcg_type_env <$> getGblEnv
-     ; lcl_env <- getLclTypeEnv
-     ; dflags <- getDynFlags
-     ; (discards, substitutions) <-
-        go (gbl_env, lcl_env, top_env) (maxValidSubstitutions dflags)
-         $ localsFirst $ globalRdrEnvElts rdr_env
-     ; return $ ppUnless (null substitutions) $
-                 hang (text "Valid substitutions include")
-                  2 (vcat (map (ppr_sub rdr_env) substitutions)
-                    $$ ppWhen discards subsDiscardMsg) }
-  where
-    hole_ty :: TcPredType
-    hole_ty = ctEvPred (ctEvidence ct)
-
-    hole_env = ctLocEnv $ ctEvLoc $ ctEvidence ct
-
-    localsFirst :: [GlobalRdrElt] -> [GlobalRdrElt]
-    localsFirst elts = lcl ++ gbl
-      where (lcl, gbl) = partition gre_lcl elts
-
-    getBndrOcc :: TcIdBinder -> OccName
-    getBndrOcc (TcIdBndr id _) = occName $ getName id
-    getBndrOcc (TcIdBndr_ExpType name _ _) = occName $ getName name
-
-    relBindSet =  mkOccSet $ map getBndrOcc $ tcl_bndrs hole_env
-
-    shouldBeSkipped :: GlobalRdrElt -> Bool
-    shouldBeSkipped el = (occName $ gre_name el) `elemOccSet` relBindSet
-
-    ppr_sub :: GlobalRdrEnv -> Id -> SDoc
-    ppr_sub rdr_env id = case lookupGRE_Name rdr_env (idName id) of
-        Just elt -> sep [ idAndTy, nest 2 (parens $ pprNameProvenance elt)]
-        _ -> idAndTy
-      where name = idName id
-            ty = varType id
-            idAndTy = (pprPrefixOcc name <+> dcolon <+> pprType ty)
-
-    tyToId :: TyThing -> Maybe Id
-    tyToId (AnId i) = Just i
-    tyToId (AConLike c) = conLikeWrapId_maybe c
-    tyToId _ = Nothing
-
-    tcTyToId :: TcTyThing -> Maybe Id
-    tcTyToId (AGlobal id) = tyToId id
-    tcTyToId (ATcId id _) = Just id
-    tcTyToId _ = Nothing
-
-    substituteable :: Id -> Bool
-    substituteable = tcEqType hole_ty . varType
-
-    lookupTopId :: HscEnv -> Name -> IO (Maybe Id)
-    lookupTopId env name =
-        maybe Nothing tyToId <$> lookupTypeHscEnv env name
-
-    lookupGblId :: TypeEnv -> Name -> Maybe Id
-    lookupGblId env name = maybe Nothing tyToId $ lookupTypeEnv env name
-
-    lookupLclId :: TcTypeEnv -> Name -> Maybe Id
-    lookupLclId env name = maybe Nothing tcTyToId $ lookupNameEnv env name
-
-    go ::  (TypeEnv, TcTypeEnv, HscEnv) -> Maybe Int -> [GlobalRdrElt]
-       -> TcM (Bool, [Id])
-    go = go_ []
-
-    go_ ::  [Id] -> (TypeEnv, TcTypeEnv, HscEnv) -> Maybe Int -> [GlobalRdrElt]
-         -> TcM (Bool, [Id])
-    go_ subs _ _ [] = return (False, reverse subs)
-    go_ subs _ (Just 0) _ = return (True, reverse subs)
-    go_ subs envs@(gbl,lcl,top) maxleft (el:elts) =
-       if shouldBeSkipped el then discard_it
-         else do { maybeId <- liftIO lookupId
-                 ; case maybeId of
-                     Just id | substituteable id ->
-                       go_ (id:subs) envs ((\n -> n - 1) <$> maxleft) elts
-                     _ -> discard_it }
-      where name = gre_name el
-            discard_it = go_ subs envs maxleft elts
-            getTopId = lookupTopId top name
-            gbl_id = lookupGblId gbl name
-            lcl_id = lookupLclId lcl name
-            lookupId = if (isJust lcl_id) then return lcl_id
-                       else if (isJust gbl_id) then return gbl_id else getTopId
-
-
-validSubstitutions _ = return empty
-
+mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)
+
+-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module
+-- imports
+validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the
+                                        -- implications and the tidy environment
+                       -> [Ct]          -- Unsolved simple constraints
+                       -> Ct            -- The hole constraint.
+                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context
+                                                    -- with a possibly updated
+                                                    -- tidy environment, and
+                                                    -- the message.
+validHoleFits ctxt@(CEC {cec_encl = implics
+                             , cec_tidy = lcl_env}) simps ct
+  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct
+       ; return (ctxt {cec_tidy = tidy_env}, msg) }
 
 -- See Note [Constraints include ...]
 givenConstraintsMsg :: ReportErrCtxt -> SDoc
 givenConstraintsMsg ctxt =
     let constraints :: [(Type, RealSrcSpan)]
         constraints =
-          do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt
+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt
              ; constraint <- given
-             ; return (varType constraint, tcl_loc env) }
+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }
 
         pprConstraint (constraint, loc) =
           ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
@@ -1246,44 +1281,6 @@ mkIPErr ctxt cts
     (ct1:_) = cts
 
 {-
-Note [Valid substitutions include ...]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-`validSubstitutions` returns the "Valid substitutions include ..." message.
-For example, look at the following definitions in a file called test.hs:
-
-    ps :: String -> IO ()
-    ps = putStrLn
-
-    ps2 :: a -> IO ()
-    ps2 _ = putStrLn "hello, world"
-
-    main :: IO ()
-    main = _ "hello, world"
-
-The hole in `main` would generate the message:
-
-    Valid substitutions include
-      ps :: String -> IO () ((defined at test.hs:2:1)
-      putStrLn :: String -> IO ()
-        (imported from ‘Prelude’ at test.hs:1:1
-         (and originally defined in ‘System.IO’))
-      putStr :: String -> IO ()
-        (imported from ‘Prelude’ at test.hs:1:1
-         (and originally defined in ‘System.IO’))
-
-Valid substitutions are found by checking names in scope.
-
-Currently the implementation only looks at exact type matches, as given by
-`tcEqType`, so we DO NOT report `ps2` as a valid substitution in the example,
-even though it fits in the hole. To determine that `ps2` fits in the hole,
-we would need to check ids for subsumption, i.e. that the type of the hole is
-a subtype of the id. This can be done using `tcSubType` from `TcUnify` and
-`tcCheckSatisfiability` in `TcSimplify`.  Unfortunately, `TcSimplify` uses
-`TcErrors` to report errors found during constraint checking, so checking for
-subsumption in holes would involve shuffling some code around in `TcSimplify`,
-to make a non-error reporting constraint satisfiability checker which could
-then be used for checking whether a given id satisfies the constraints imposed
-by the hole.
 
 Note [Constraints include ...]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1447,9 +1444,9 @@ the unsolved (t ~ Bool), t won't look like an untouchable meta-var
 any more.  So we don't assert that it is.
 -}
 
-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 -- Don't have multiple equality errors from the same location
 -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
 mkEqErr _ [] = panic "mkEqErr"
 
@@ -1589,9 +1586,12 @@ mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
              -> Maybe SwapFlag   -- Nothing <=> not sure
              -> TcType -> TcType -> TcM ErrMsg
 mkEqErr_help dflags ctxt report ct oriented ty1 ty2
-  | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
-  | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt report ct swapped  tv2 ty1
-  | otherwise                        = reportEqErr ctxt report ct oriented ty1 ty2
+  | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1
+  = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 co2 ty1
+  | otherwise
+  = reportEqErr ctxt report ct oriented ty1 ty2
   where
     swapped = fmap flipSwap oriented
 
@@ -1606,18 +1606,18 @@ reportEqErr ctxt report ct oriented ty1 ty2
 
 mkTyVarEqErr, mkTyVarEqErr'
   :: DynFlags -> ReportErrCtxt -> Report -> Ct
-             -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
+             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
 -- tv1 and ty2 are already tidied
-mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
-  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
-       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 }
+mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)
+       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }
 
-mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
+mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
   | not insoluble_occurs_check   -- See Note [Occurs check wins]
   , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
                             -- be oriented the other way round;
                             -- see TcCanonical.canEqTyVarTyVar
-    || isSigTyVar tv1 && not (isTyVarTy ty2)
+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)
     || ctEqRel ct == ReprEq
      -- the cases below don't really apply to ReprEq (except occurs check)
   = mkErrorMsgFromCt ctxt ct $ mconcat
@@ -1644,7 +1644,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
              extra3 = relevant_bindings $
                       ppWhen (not (null interesting_tyvars)) $
                       hang (text "Type variable kinds:") 2 $
-                      vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt))
+                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
                                 interesting_tyvars)
 
              tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
@@ -1661,9 +1661,26 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
        -- to be helpful since this is just an unimplemented feature.
        ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
 
+   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]
+   -- in TcCanonical
+  | not (k1 `tcEqType` k2)
+  = do { let main_msg = addArising (ctOrigin ct) $
+                        vcat [ hang (text "Kind mismatch: cannot unify" <+>
+                                     parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
+                                     text "with:")
+                                  2 (sep [ppr ty2, dcolon, ppr k2])
+                             , text "Their kinds differ." ]
+             cast_msg
+               | isTcReflexiveCo co1 = empty
+               | otherwise           = text "NB:" <+> ppr tv1 <+>
+                                       text "was casted to have kind" <+>
+                                       quotes (ppr k1)
+
+       ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }
+
   -- If the immediately-enclosing implication has 'tv' a skolem, and
   -- we know by now its an InferSkol kind of skolem, then presumably
-  -- it started life as a SigTv, else it'd have been unified, given
+  -- it started life as a TyVarTv, else it'd have been unified, given
   -- that there's no occurs-check or forall problem
   | (implic:_) <- cec_encl ctxt
   , Implic { ic_skols = skols } <- implic
@@ -1676,7 +1693,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic
   , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
   , not (null esc_skols)
   = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
@@ -1694,26 +1711,27 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
                                            what <+> text "variables are")
                                <+> text "bound by"
                              , nest 2 $ ppr skol_info
-                             , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]
+                             , nest 2 $ text "at" <+>
+                               ppr (tcl_loc (implicLclEnv implic)) ] ]
        ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
 
   -- Nastiest case: attempt to unify an untouchable variable
   -- So tv is a meta tyvar (or started that way before we
   -- generalised it).  So presumably it is an *untouchable*
-  -- meta tyvar or a SigTv, else it'd have been unified
+  -- meta tyvar or a TyVarTv, else it'd have been unified
   -- See Note [Error messages for untouchables]
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_given = given
-           , ic_tclvl = lvl, ic_info = skol_info } <- implic
+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
   = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
-           , ppr tv1 )  -- See Note [Error messages for untouchables]
+           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
     do { let msg = important $ misMatchMsg ct oriented ty1 ty2
              tclvl_extra = important $
                   nest 2 $
                   sep [ quotes (ppr tv1) <+> text "is untouchable"
                       , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
                       , nest 2 $ text "bound by" <+> ppr skol_info
-                      , nest 2 $ text "at" <+> ppr (tcl_loc env) ]
+                      , nest 2 $ text "at" <+>
+                        ppr (tcl_loc (implicLclEnv implic)) ]
              tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
              add_sig  = important $ suggestAddSig ctxt ty1 ty2
        ; mkErrorMsgFromCt ctxt ct $ mconcat
@@ -1725,6 +1743,9 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
         -- Consider an ambiguous top-level constraint (a ~ F a)
         -- Not an occurs check, because F is a type function.
   where
+    Pair _ k1 = tcCoercionKind co1
+    k2        = typeKind ty2
+
     ty1 = mkTyVarTy tv1
     occ_check_expand       = occCheckForErrors dflags tv1 ty2
     insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2
@@ -1766,8 +1787,9 @@ mkEqInfoMsg ct ty1 ty2
     tyfun_msg | Just tc1 <- mb_fun1
               , Just tc2 <- mb_fun2
               , tc1 == tc2
+              , not (isInjectiveTyCon tc1 Nominal)
               = text "NB:" <+> quotes (ppr tc1)
-                <+> text "is a type function, and may not be injective"
+                <+> text "is a non-injective type family"
               | otherwise = empty
 
 isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
@@ -1798,7 +1820,8 @@ misMatchOrCND ctxt ct oriented ty1 ty2
     eq_pred = ctEvPred ev
     orig    = ctEvOrigin ev
     givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
-              -- Keep only UserGivens that have some equalities
+              -- Keep only UserGivens that have some equalities.
+              -- See Note [Suppress redundant givens during error reporting]
 
 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
 couldNotDeduce givens (wanteds, orig)
@@ -1812,11 +1835,49 @@ pp_givens givens
          (g:gs) ->      ppr_given (text "from the context:") g
                  : map (ppr_given (text "or from:")) gs
     where
-       ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
-                                , ic_env = env })
-           = hang (herald <+> pprEvVarTheta gs)
+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })
+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))
+             -- See Note [Suppress redundant givens during error reporting]
+             -- for why we use mkMinimalBySCs above.
                 2 (sep [ text "bound by" <+> ppr skol_info
-                       , text "at" <+> ppr (tcl_loc env) ])
+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])
+
+{-
+Note [Suppress redundant givens during error reporting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When GHC is unable to solve a constraint and prints out an error message, it
+will print out what given constraints are in scope to provide some context to
+the programmer. But we shouldn't print out /every/ given, since some of them
+are not terribly helpful to diagnose type errors. Consider this example:
+
+  foo :: Int :~: Int -> a :~: b -> a :~: c
+  foo Refl Refl = Refl
+
+When reporting that GHC can't solve (a ~ c), there are two givens in scope:
+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
+redundant), so it's not terribly useful to report it in an error message.
+To accomplish this, we discard any Implications that do not bind any
+equalities by filtering the `givens` selected in `misMatchOrCND` (based on
+the `ic_no_eqs` field of the Implication).
+
+But this is not enough to avoid all redundant givens! Consider this example,
+from #15361:
+
+  goo :: forall (a :: Type) (b :: Type) (c :: Type).
+         a :~~: b -> a :~~: c
+  goo HRefl = HRefl
+
+Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
+The (* ~ *) part arises due the kinds of (:~~:) being unified. More
+importantly, (* ~ *) is redundant, so we'd like not to report it. However,
+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
+ic_no_eqs field), so the test above will keep it wholesale.
+
+To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
+part. This works because mkMinimalBySCs eliminates reflexive equalities in
+addition to superclasses (see Note [Remove redundant provided dicts]
+in TcPatSyn).
+-}
 
 extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
 -- Add on extra info about skolem constants
@@ -1832,12 +1893,9 @@ extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
 extraTyVarInfo ctxt tv
   = ASSERT2( isTyVar tv, ppr tv )
     case tcTyVarDetails tv of
-          SkolemTv {}   -> pprSkol implics tv
-          RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem"
+          SkolemTv {}   -> pprSkols ctxt [tv]
+          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"
           MetaTv {}     -> empty
-  where
-    implics = cec_encl ctxt
-    pp_tv = quotes (ppr tv)
 
 suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
 -- See Note [Suggest adding a type signature]
@@ -1852,7 +1910,8 @@ suggestAddSig ctxt ty1 ty2
     inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
     get_inf ty | Just tv <- tcGetTyVar_maybe ty
                , isSkolemTyVar tv
-               , InferSkol prs <- ic_info (getSkolemInfo (cec_encl ctxt) tv)
+               , (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv]
+               , InferSkol prs <- ic_info implic
                = map fst prs
                | otherwise
                = []
@@ -1924,8 +1983,7 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
   | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)
   | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
   | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
-  | isLiftedTypeKind exp && not (isConstraintKind exp)
-                                                 = (False, Nothing, msg4)
+  | tcIsLiftedTypeKind exp                       = (False, Nothing, msg4)
   | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)
   | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)
   | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
@@ -1962,7 +2020,7 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
         -> empty
 
     thing_msg = case maybe_thing of
-                  Just thing -> \_ -> quotes (ppr thing) <+> text "is"
+                  Just thing -> \_ -> quotes thing <+> text "is"
                   Nothing    -> \vowel -> text "got a" <>
                                           if vowel then char 'n' else empty
     msg2 = sep [ text "Expecting a lifted type, but"
@@ -1972,38 +2030,48 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
     msg4 = maybe_num_args_msg $$
            sep [ text "Expected a type, but"
                , maybe (text "found something with kind")
-                       (\thing -> quotes (ppr thing) <+> text "has kind")
+                       (\thing -> quotes thing <+> text "has kind")
                        maybe_thing
-               , quotes (ppr act) ]
+               , quotes (pprWithTYPE act) ]
 
     msg5 th = hang (text "Expected" <+> kind_desc <> comma)
-                 2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+>
+                 2 (text "but" <+> quotes th <+> text "has kind" <+>
                     quotes (ppr act))
       where
-        kind_desc | isConstraintKind exp = text "a constraint"
+        kind_desc | tcIsConstraintKind exp = text "a constraint"
+
+                    -- TYPE t0
+                  | Just (tc, [arg]) <- tcSplitTyConApp_maybe exp
+                  , tc `hasKey` tYPETyConKey
+                  , tcIsTyVarTy arg      = sdocWithDynFlags $ \dflags ->
+                                           if gopt Opt_PrintExplicitRuntimeReps dflags
+                                           then text "kind" <+> quotes (ppr exp)
+                                           else text "a type"
+
                   | otherwise            = text "kind" <+> quotes (ppr exp)
 
     num_args_msg = case level of
-      TypeLevel -> Nothing
       KindLevel
+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)
+           -- if one is a meta-tyvar, then it's possible that the user
+           -- has asked for something impredicative, and we couldn't unify.
+           -- Don't bother with counting arguments.
         -> let n_act = count_args act
                n_exp = count_args exp in
            case n_act - n_exp of
-             n | n /= 0
+             n | n > 0   -- we don't know how many args there are, so don't
+                         -- recommend removing args that aren't
                , Just thing <- maybe_thing
-               , case errorThingNumArgs_maybe thing of
-                   Nothing           -> n > 0
-                   Just num_act_args -> num_act_args >= -n
-                     -- don't report to strip off args that aren't there
                -> Just $ text "Expecting" <+> speakN (abs n) <+>
-                         more_or_fewer <+> quotes (ppr thing)
+                         more <+> quotes thing
                where
-                 more_or_fewer
-                  | n < 0     = text "fewer arguments to"
+                 more
                   | n == 1    = text "more argument to"
                   | otherwise = text "more arguments to"  -- n > 1
              _ -> Nothing
 
+      _ -> Nothing
+
     maybe_num_args_msg = case num_args_msg of
       Nothing -> empty
       Just m  -> m
@@ -2310,10 +2378,7 @@ mkDictErr ctxt cts
     -- When simplifying [W] Ord (Set a), we need
     --    [W] Eq a, [W] Ord a
     -- but we really only want to report the latter
-    elim_superclasses cts
-      = filter (\ct -> any (eqType (ctPred ct)) min_preds) cts
-      where
-        min_preds = mkMinimalBySCs (map ctPred cts)
+    elim_superclasses cts = mkMinimalBySCs ctPred cts
 
 mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
             -> TcM (ReportErrCtxt, SDoc)
@@ -2441,13 +2506,18 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
                = empty
 
     drv_fixes = case orig of
-                   DerivOrigin      -> [drv_fix]
-                   DerivOriginDC {} -> [drv_fix]
-                   DerivOriginCoerce {} -> [drv_fix]
+                   DerivClauseOrigin                  -> [drv_fix False]
+                   StandAloneDerivOrigin              -> [drv_fix True]
+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]
+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]
                    _                -> []
 
-    drv_fix = hang (text "use a standalone 'deriving instance' declaration,")
-                 2 (text "so you can specify the instance context yourself")
+    drv_fix standalone_wildcard
+      | standalone_wildcard
+      = text "fill in the wildcard constraint yourself"
+      | otherwise
+      = hang (text "use a standalone 'deriving instance' declaration,")
+           2 (text "so you can specify the instance context yourself")
 
     -- Normal overlap error
     overlap_msg
@@ -2484,12 +2554,13 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
 
     matching_givens = mapMaybe matchable useful_givens
 
-    matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })
       = case ev_vars_matching of
              [] -> Nothing
              _  -> Just $ hang (pprTheta ev_vars_matching)
                             2 (sep [ text "bound by" <+> ppr skol_info
-                                   , text "at" <+> ppr (tcl_loc env) ])
+                                   , text "at" <+>
+                                     ppr (tcl_loc (implicLclEnv implic)) ])
         where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
               ev_var_matches ty = case getClassPredTys_maybe ty of
                  Just (clas', tys')
@@ -2791,17 +2862,24 @@ mkAmbigMsg prepend_msg ct
     is_or_are [_] = text "is"
     is_or_are _   = text "are"
 
-pprSkol :: [Implication] -> TcTyVar -> SDoc
-pprSkol implics tv
-  = case skol_info of
-      UnkSkol -> quotes (ppr tv) <+> text "is an unknown type variable"
-      _       -> ppr_rigid (pprSkolInfo skol_info)
+pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc
+pprSkols ctxt tvs
+  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))
   where
-    Implic { ic_info = skol_info } = getSkolemInfo implics tv
-    ppr_rigid pp_info
-       = hang (quotes (ppr tv) <+> text "is a rigid type variable bound by")
-            2 (sep [ pp_info
-                   , text "at" <+> ppr (getSrcSpan tv) ])
+    pp_one (Implic { ic_info = skol_info }, tvs)
+      | UnkSkol <- skol_info
+      = hang (pprQuotedList tvs)
+           2 (is_or_are tvs "an" "unknown")
+      | otherwise
+      = vcat [ hang (pprQuotedList tvs)
+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")
+             , nest 2 (pprSkolInfo skol_info)
+             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]
+
+    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective
+                                      <+> text "type variable"
+    is_or_are _   _       adjective = text "are" <+> text adjective
+                                      <+> text "type variables"
 
 getAmbigTkvs :: Ct -> ([Var],[Var])
 getAmbigTkvs ct
@@ -2811,15 +2889,23 @@ getAmbigTkvs ct
     ambig_tkvs = filter isAmbiguousTyVar tkvs
     dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
 
-getSkolemInfo :: [Implication] -> TcTyVar -> Implication
--- Get the skolem info for a type variable
--- from the implication constraint that binds it
-getSkolemInfo [] tv
-  = pprPanic "No skolem info:" (ppr tv)
+getSkolemInfo :: [Implication] -> [TcTyVar]
+              -> [(Implication, [TcTyVar])]
+-- Get the skolem info for some type variables
+-- from the implication constraints that bind them
+--
+-- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty
+getSkolemInfo _ []
+  = []
+
+getSkolemInfo [] tvs
+  = pprPanic "No skolem info:" (ppr tvs)
 
-getSkolemInfo (implic:implics) tv
-  | tv `elem` ic_skols implic = implic
-  | otherwise                 = getSkolemInfo implics tv
+getSkolemInfo (implic:implics) tvs
+  | null tvs_here =                      getSkolemInfo implics tvs
+  | otherwise     = (implic, tvs_here) : getSkolemInfo implics tvs_other
+  where
+    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs
 
 -----------------------
 -- relevantBindings looks at the value environment and finds values whose
@@ -2858,7 +2944,7 @@ relevantBindings want_filtering ctxt ct
        ; (tidy_env', docs, discards)
               <- go dflags env1 ct_tvs (maxRelevantBinds dflags)
                     emptyVarSet [] False
-                    (remove_shadowing $ tcl_bndrs lcl_env)
+                    (removeBindingShadowing $ tcl_bndrs lcl_env)
          -- tcl_bndrs has the innermost bindings first,
          -- which are probably the most relevant ones
 
@@ -2884,25 +2970,17 @@ relevantBindings want_filtering ctxt ct
     dec_max :: Maybe Int -> Maybe Int
     dec_max = fmap (\n -> n - 1)
 
-    ---- fixes #12177
-    ---- builds up a list of bindings whose OccName has not been seen before
-    remove_shadowing :: [TcIdBinder] -> [TcIdBinder]
-    remove_shadowing bindings = reverse $ fst $ foldl
-      (\(bindingAcc, seenNames) binding ->
-        if (occName binding) `elemOccSet` seenNames -- if we've seen it
-          then (bindingAcc, seenNames)              -- skip it
-          else (binding:bindingAcc, extendOccSet seenNames (occName binding)))
-      ([], emptyOccSet) bindings
 
     go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
        -> Bool                          -- True <=> some filtered out due to lack of fuel
-       -> [TcIdBinder]
+       -> [TcBinder]
        -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
                                         -- because of lack of fuel
     go _ tidy_env _ _ _ docs discards []
       = return (tidy_env, reverse docs, discards)
     go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
       = case tc_bndr of
+          TcTvBndr {} -> discard_it
           TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
           TcIdBndr_ExpType name et top_lvl ->
             do { mb_ty <- readExpType_maybe et
@@ -2949,15 +3027,11 @@ relevantBindings want_filtering ctxt ct
                  else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen
                          (doc:docs) discards tc_bndrs }
 
+
 discardMsg :: SDoc
 discardMsg = text "(Some bindings suppressed;" <+>
              text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
 
-subsDiscardMsg :: SDoc
-subsDiscardMsg =
-    text "(Some substitutions suppressed;" <+>
-    text "use -fmax-valid-substitutions=N or -fno-max-valid-substitutions)"
-
 -----------------------
 warnDefaulting :: [Ct] -> Type -> TcM ()
 warnDefaulting wanteds default_ty
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
new file mode 100644
index 0000000000..8d8aa9bb10
--- /dev/null
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -0,0 +1,70 @@
+
+-- (those who have too heavy dependencies for TcEvidence)
+module TcEvTerm
+    ( evDelayedError, evCallStack )
+where
+
+import GhcPrelude
+
+import FastString
+import Type
+import CoreSyn
+import MkCore
+import Literal ( Literal(..) )
+import TcEvidence
+import HscTypes
+import DynFlags
+import Name
+import Module
+import CoreUtils
+import PrelNames
+import SrcLoc
+
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in TcSimplify
+evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError ty msg
+  = EvExpr $
+    Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
+  where
+    errorId = tYPE_ERROR_ID
+    litMsg  = Lit (MachStr (fastStringToByteString msg))
+
+-- Dictionary for CallStack implicit parameters
+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
+    EvCallStack -> m EvExpr
+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
+evCallStack cs = do
+  df            <- getDynFlags
+  m             <- getModule
+  srcLocDataCon <- lookupDataCon srcLocDataConName
+  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
+               sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
+                        , mkStringExprFS (moduleNameFS $ moduleName m)
+                        , mkStringExprFS (srcSpanFile l)
+                        , return $ mkIntExprInt df (srcSpanStartLine l)
+                        , return $ mkIntExprInt df (srcSpanStartCol l)
+                        , return $ mkIntExprInt df (srcSpanEndLine l)
+                        , return $ mkIntExprInt df (srcSpanEndCol l)
+                        ]
+
+  emptyCS <- Var <$> lookupId emptyCallStackName
+
+  pushCSVar <- lookupId pushCallStackName
+  let pushCS name loc rest =
+        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
+
+  let mkPush name loc tm = do
+        nameExpr <- mkStringExprFS name
+        locExpr <- mkSrcLoc loc
+        -- at this point tm :: IP sym CallStack
+        -- but we need the actual CallStack to pass to pushCS,
+        -- so we use unwrapIP to strip the dictionary wrapper
+        -- See Note [Overview of implicit CallStacks]
+        let ip_co = unwrapIP (exprType tm)
+        return (pushCS nameExpr locExpr (Cast tm ip_co))
+
+  case cs of
+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
+    EvCsEmpty -> return emptyCS
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index eb809ab013..dffbd2bea3 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -13,11 +13,17 @@ module TcEvidence (
   -- Evidence bindings
   TcEvBinds(..), EvBindsVar(..),
   EvBindMap(..), emptyEvBindMap, extendEvBinds,
-  lookupEvBind, evBindMapBinds, foldEvBindMap, isEmptyEvBindMap,
+  lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap,
+  isEmptyEvBindMap,
   EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
-  sccEvBinds, evBindVar,
-  EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors,
-  EvLit(..), evTermCoercion,
+  evBindVar, isCoEvBindsVar,
+
+  -- EvTerm (already a CoreExpr)
+  EvTerm(..), EvExpr,
+  evId, evCoercion, evCast, evDFunApp,  evSelector,
+  mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars,
+
+  evTermCoercion, evTermCoercion_maybe,
   EvCallStack(..),
   EvTypeable(..),
 
@@ -29,16 +35,20 @@ module TcEvidence (
   mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,
   mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,
   tcDowngradeRole,
-  mkTcAxiomRuleCo, mkTcCoherenceLeftCo, mkTcCoherenceRightCo, mkTcPhantomCo,
+  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo,
+  mkTcCoherenceLeftCo,
+  mkTcCoherenceRightCo,
   mkTcKindCo,
   tcCoercionKind, coVarsOfTcCo,
   mkTcCoVarCo,
-  isTcReflCo,
+  isTcReflCo, isTcReflexiveCo,
   tcCoercionRole,
   unwrapIP, wrapIP
   ) where
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Var
 import CoAxiom
 import Coercion
@@ -54,12 +64,15 @@ import VarSet
 import Name
 import Pair
 
+import CoreSyn
+import Class ( classSCSelId )
+import Id ( isEvVar )
+import CoreFVs ( exprSomeFreeVars )
+
 import Util
 import Bag
-import Digraph
 import qualified Data.Data as Data
 import Outputable
-import FastString
 import SrcLoc
 import Data.IORef( IORef )
 import UniqSet
@@ -98,14 +111,18 @@ mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType]
                        -> [TcCoercion] -> TcCoercionR
 mkTcForAllCo           :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion
 mkTcForAllCos          :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion
-mkTcNthCo              :: Int -> TcCoercion -> TcCoercion
+mkTcNthCo              :: Role -> Int -> TcCoercion -> TcCoercion
 mkTcLRCo               :: LeftOrRight -> TcCoercion -> TcCoercion
 mkTcSubCo              :: TcCoercionN -> TcCoercionR
 maybeTcSubCo           :: EqRel -> TcCoercion -> TcCoercion
 tcDowngradeRole        :: Role -> Role -> TcCoercion -> TcCoercion
 mkTcAxiomRuleCo        :: CoAxiomRule -> [TcCoercion] -> TcCoercionR
-mkTcCoherenceLeftCo    :: TcCoercion -> TcCoercionN -> TcCoercion
-mkTcCoherenceRightCo   :: TcCoercion -> TcCoercionN -> TcCoercion
+mkTcGReflRightCo       :: Role -> TcType -> TcCoercionN -> TcCoercion
+mkTcGReflLeftCo        :: Role -> TcType -> TcCoercionN -> TcCoercion
+mkTcCoherenceLeftCo    :: Role -> TcType -> TcCoercionN
+                       -> TcCoercion -> TcCoercion
+mkTcCoherenceRightCo   :: Role -> TcType -> TcCoercionN
+                       -> TcCoercion -> TcCoercion
 mkTcPhantomCo          :: TcCoercionN -> TcType -> TcType -> TcCoercionP
 mkTcKindCo             :: TcCoercion -> TcCoercionN
 mkTcCoVarCo            :: CoVar -> TcCoercion
@@ -115,6 +132,10 @@ tcCoercionRole         :: TcCoercion -> Role
 coVarsOfTcCo           :: TcCoercion -> TcTyCoVarSet
 isTcReflCo             :: TcCoercion -> Bool
 
+-- | This version does a slow check, calculating the related types and seeing
+-- if they are equal.
+isTcReflexiveCo        :: TcCoercion -> Bool
+
 mkTcReflCo             = mkReflCo
 mkTcSymCo              = mkSymCo
 mkTcTransCo            = mkTransCo
@@ -133,6 +154,8 @@ mkTcSubCo              = mkSubCo
 maybeTcSubCo           = maybeSubCo
 tcDowngradeRole        = downgradeRole
 mkTcAxiomRuleCo        = mkAxiomRuleCo
+mkTcGReflRightCo       = mkGReflRightCo
+mkTcGReflLeftCo        = mkGReflLeftCo
 mkTcCoherenceLeftCo    = mkCoherenceLeftCo
 mkTcCoherenceRightCo   = mkCoherenceRightCo
 mkTcPhantomCo          = mkPhantomCo
@@ -143,7 +166,7 @@ tcCoercionKind         = coercionKind
 tcCoercionRole         = coercionRole
 coVarsOfTcCo           = coVarsOfCo
 isTcReflCo             = isReflCo
-
+isTcReflexiveCo        = isReflexiveCo
 
 {-
 %************************************************************************
@@ -303,7 +326,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper
 mkWpEvApps args = mk_co_app_fn WpEvApp args
 
 mkWpEvVarApps :: [EvVar] -> HsWrapper
-mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map EvId vs)
+mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
 
 mkWpTyLams :: [TyVar] -> HsWrapper
 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
@@ -341,7 +364,7 @@ collectHsWrapBinders wrap = go wrap []
     go (WpEvLam v)       wraps = add_lam v (gos wraps)
     go (WpTyLam v)       wraps = add_lam v (gos wraps)
     go (WpCompose w1 w2) wraps = go w1 (w2:wraps)
-    go wrap              wraps = ([], foldl (<.>) wrap wraps)
+    go wrap              wraps = ([], foldl' (<.>) wrap wraps)
 
     gos []     = ([], WpHole)
     gos (w:ws) = go w ws
@@ -372,9 +395,11 @@ data EvBindsVar
       ebv_binds :: IORef EvBindMap,
       -- The main payload: the value-level evidence bindings
       --     (dictionaries etc)
+      -- Some Given, some Wanted
 
       ebv_tcvs :: IORef CoVarSet
       -- The free coercion vars of the (rhss of) the coercion bindings
+      -- All of these are Wanted
       --
       -- Coercions don't actually have bindings
       -- because we plug them in-place (via a mutable
@@ -383,12 +408,37 @@ data EvBindsVar
       -- See Note [Tracking redundant constraints] in TcSimplify
     }
 
+  | CoEvBindsVar {  -- See Note [Coercion evidence only]
+
+      -- See above for comments on ebv_uniq, evb_tcvs
+      ebv_uniq :: Unique,
+      ebv_tcvs :: IORef CoVarSet
+    }
+
 instance Data.Data TcEvBinds where
   -- Placeholder; we can't travers into TcEvBinds
   toConstr _   = abstractConstr "TcEvBinds"
   gunfold _ _  = error "gunfold"
   dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
 
+{- Note [Coercion evidence only]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Class constraints etc give rise to /term/ bindings for evidence, and
+we have nowhere to put term bindings in /types/.  So in some places we
+use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level
+evidence bindings are allowed.  Notebly ():
+
+  - Places in types where we are solving kind constraints (all of which
+    are equalities); see solveEqualities, solveLocalEqualities,
+    checkTvConstraints
+
+  - When unifying forall-types
+-}
+
+isCoEvBindsVar :: EvBindsVar -> Bool
+isCoEvBindsVar (CoEvBindsVar {}) = True
+isCoEvBindsVar (EvBindsVar {})   = False
+
 -----------------
 newtype EvBindMap
   = EvBindMap {
@@ -434,6 +484,10 @@ evBindMapBinds = foldEvBindMap consBag emptyBag
 foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
 foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs)
 
+filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap
+filterEvBindMap k (EvBindMap { ev_bind_varenv = env })
+  = EvBindMap { ev_bind_varenv = filterDVarEnv k env }
+
 instance Outputable EvBindMap where
   ppr (EvBindMap m) = ppr m
 
@@ -452,43 +506,62 @@ evBindVar = eb_lhs
 mkWantedEvBind :: EvVar -> EvTerm -> EvBind
 mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }
 
-
+-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm
 mkGivenEvBind :: EvVar -> EvTerm -> EvBind
 mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
 
+
+-- An EvTerm is, conceptually, a CoreExpr that implements the constraint.
+-- Unfortunately, we cannot just do
+--   type EvTerm  = CoreExpr
+-- Because of staging problems issues around EvTypeable
 data EvTerm
-  = EvId EvId                    -- Any sort of evidence Id, including coercions
+  = EvExpr EvExpr
 
-  | EvCoercion TcCoercion        -- coercion bindings
-                                 -- See Note [Coercion evidence terms]
+  | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
-  | EvCast EvTerm TcCoercionR    -- d |> co
+  | EvFun     -- /\as \ds. let binds in v
+      { et_tvs   :: [TyVar]
+      , et_given :: [EvVar]
+      , et_binds :: TcEvBinds -- This field is why we need an EvFun
+                              -- constructor, and can't just use EvExpr
+      , et_body  :: EvVar }
 
-  | EvDFunApp DFunId             -- Dictionary instance application
-       [Type] [EvTerm]
+  deriving Data.Data
 
-  | EvDelayedError Type FastString  -- Used with Opt_DeferTypeErrors
-                               -- See Note [Deferring coercion errors to runtime]
-                               -- in TcSimplify
+type EvExpr = CoreExpr
 
-  | EvSuperClass EvTerm Int      -- n'th superclass. Used for both equalities and
-                                 -- dictionaries, even though the former have no
-                                 -- selector Id.  We count up from _0_
+-- An EvTerm is (usually) constructed by any of the constructors here
+-- and those more complicates ones who were moved to module TcEvTerm
 
-  | EvLit EvLit       -- Dictionary for KnownNat and KnownSymbol classes.
-                      -- Note [KnownNat & KnownSymbol and EvLit]
+-- | Any sort of evidence Id, including coercions
+evId ::  EvId -> EvExpr
+evId = Var
 
-  | EvCallStack EvCallStack      -- Dictionary for CallStack implicit parameters
+-- coercion bindings
+-- See Note [Coercion evidence terms]
+evCoercion :: TcCoercion -> EvTerm
+evCoercion co = EvExpr (Coercion co)
 
-  | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
+-- | d |> co
+evCast :: EvExpr -> TcCoercion -> EvTerm
+evCast et tc | isReflCo tc = EvExpr et
+             | otherwise   = EvExpr (Cast et tc)
 
-  | EvSelector Id [Type] [EvTerm] -- Selector id plus the types at which it
-                                  -- should be instantiated, used for HasField
-                                  -- dictionaries; see Note [HasField instances]
-                                  -- in TcInterface
+-- Dictionary instance application
+evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm
+evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets
 
-  deriving Data.Data
+-- Selector id plus the types at which it
+-- should be instantiated, used for HasField
+-- dictionaries; see Note [HasField instances]
+-- in TcInterface
+evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr
+evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms
 
+-- Dictionary for (Typeable ty)
+evTypeable :: Type -> EvTypeable -> EvTerm
+evTypeable = EvTypeable
 
 -- | Instructions on how to make a 'Typeable' dictionary.
 -- See Note [Typeable evidence terms]
@@ -513,16 +586,11 @@ data EvTypeable
     -- (see Trac #10348)
   deriving Data.Data
 
-data EvLit
-  = EvNum Integer
-  | EvStr FastString
-    deriving Data.Data
-
 -- | Evidence for @CallStack@ implicit parameters.
 data EvCallStack
   -- See Note [Overview of implicit CallStacks]
   = EvCsEmpty
-  | EvCsPushCall Name RealSrcSpan EvTerm
+  | EvCsPushCall Name RealSrcSpan EvExpr
     -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at
     -- @loc@, in a calling context @stk@.
   deriving Data.Data
@@ -584,54 +652,6 @@ Conclusion: a new wanted coercion variable should be made mutable.
  from super classes will be "given" and hence rigid]
 
 
-Note [KnownNat & KnownSymbol and EvLit]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A part of the type-level literals implementation are the classes
-"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
-defining singleton values.  Here is the key stuff from GHC.TypeLits
-
-  class KnownNat (n :: Nat) where
-    natSing :: SNat n
-
-  newtype SNat (n :: Nat) = SNat Integer
-
-Conceptually, this class has infinitely many instances:
-
-  instance KnownNat 0       where natSing = SNat 0
-  instance KnownNat 1       where natSing = SNat 1
-  instance KnownNat 2       where natSing = SNat 2
-  ...
-
-In practice, we solve `KnownNat` predicates in the type-checker
-(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
-The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
-
-We make the following assumptions about dictionaries in GHC:
-  1. The "dictionary" for classes with a single method---like `KnownNat`---is
-     a newtype for the type of the method, so using a evidence amounts
-     to a coercion, and
-  2. Newtypes use the same representation as their definition types.
-
-So, the evidence for `KnownNat` is just a value of the representation type,
-wrapped in two newtype constructors: one to make it into a `SNat` value,
-and another to make it into a `KnownNat` dictionary.
-
-Also note that `natSing` and `SNat` are never actually exposed from the
-library---they are just an implementation detail.  Instead, users see
-a more convenient function, defined in terms of `natSing`:
-
-  natVal :: KnownNat n => proxy n -> Integer
-
-The reason we don't use this directly in the class is that it is simpler
-and more efficient to pass around an integer rather than an entier function,
-especially when the `KnowNat` evidence is packaged up in an existential.
-
-The story for kind `Symbol` is analogous:
-  * class KnownSymbol
-  * newtype SSymbol
-  * Evidence: EvLit (EvStr n)
-
-
 Note [Overview of implicit CallStacks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 (See https://ghc.haskell.org/trac/ghc/wiki/ExplicitCallStack/ImplicitLocations)
@@ -756,17 +776,25 @@ Important Details:
 
 -}
 
-mkEvCast :: EvTerm -> TcCoercion -> EvTerm
+mkEvCast :: EvExpr -> TcCoercion -> EvTerm
 mkEvCast ev lco
-  | ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
-    isTcReflCo lco = ev
-  | otherwise      = EvCast ev lco
-
-mkEvScSelectors :: EvTerm -> Class -> [TcType] -> [(TcPredType, EvTerm)]
-mkEvScSelectors ev cls tys
+  | ASSERT2( tcCoercionRole lco == Representational
+           , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]))
+    isTcReflCo lco = EvExpr ev
+  | otherwise      = evCast ev lco
+
+
+mkEvScSelectors         -- Assume   class (..., D ty, ...) => C a b
+  :: Class -> [TcType]  -- C ty1 ty2
+  -> [(TcPredType,      -- D ty[ty1/a,ty2/b]
+       EvExpr)          -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b]
+     ]
+mkEvScSelectors cls tys
    = zipWith mk_pr (immSuperClasses cls tys) [0..]
   where
-    mk_pr pred i = (pred, EvSuperClass ev i)
+    mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys)
+      where
+        sc_sel_id  = classSCSelId cls i -- Zero-indexed
 
 emptyTcEvBinds :: TcEvBinds
 emptyTcEvBinds = EvBinds emptyBag
@@ -775,50 +803,58 @@ isEmptyTcEvBinds :: TcEvBinds -> Bool
 isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 
-
-evTermCoercion :: EvTerm -> TcCoercion
+evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion
 -- Applied only to EvTerms of type (s~t)
 -- See Note [Coercion evidence terms]
-evTermCoercion (EvId v)        = mkCoVarCo v
-evTermCoercion (EvCoercion co) = co
-evTermCoercion (EvCast tm co)  = mkCoCast (evTermCoercion tm) co
-evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)
+evTermCoercion_maybe ev_term
+  | EvExpr e <- ev_term = go e
+  | otherwise           = Nothing
+  where
+    go :: EvExpr -> Maybe TcCoercion
+    go (Var v)       = return (mkCoVarCo v)
+    go (Coercion co) = return co
+    go (Cast tm co)  = do { co' <- go tm
+                          ; return (mkCoCast co' co) }
+    go _             = Nothing
+
+evTermCoercion :: EvTerm -> TcCoercion
+evTermCoercion tm = case evTermCoercion_maybe tm of
+                      Just co -> co
+                      Nothing -> pprPanic "evTermCoercion" (ppr tm)
+
+
+{- *********************************************************************
+*                                                                      *
+                  Free variables
+*                                                                      *
+********************************************************************* -}
+
+findNeededEvVars :: EvBindMap -> VarSet -> VarSet
+findNeededEvVars ev_binds seeds
+  = transCloVarSet also_needs seeds
+  where
+   also_needs :: VarSet -> VarSet
+   also_needs needs = nonDetFoldUniqSet add emptyVarSet needs
+     -- It's OK to use nonDetFoldUFM here because we immediately
+     -- forget about the ordering by creating a set
+
+   add :: Var -> VarSet -> VarSet
+   add v needs
+     | Just ev_bind <- lookupEvBind ev_binds v
+     , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind
+     , is_given
+     = evVarsOfTerm rhs `unionVarSet` needs
+     | otherwise
+     = needs
 
 evVarsOfTerm :: EvTerm -> VarSet
-evVarsOfTerm (EvId v)             = unitVarSet v
-evVarsOfTerm (EvCoercion co)      = coVarsOfCo co
-evVarsOfTerm (EvDFunApp _ _ evs)  = mapUnionVarSet evVarsOfTerm evs
-evVarsOfTerm (EvSuperClass v _)   = evVarsOfTerm v
-evVarsOfTerm (EvCast tm co)       = evVarsOfTerm tm `unionVarSet` coVarsOfCo co
-evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
-evVarsOfTerm (EvLit _)            = emptyVarSet
-evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
-evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev
-evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs
+evVarsOfTerm (EvExpr e)         = exprSomeFreeVars isEvVar e
+evVarsOfTerm (EvTypeable _ ev)  = evVarsOfTypeable ev
+evVarsOfTerm (EvFun {})         = emptyVarSet -- See Note [Free vars of EvFun]
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
 
--- | Do SCC analysis on a bag of 'EvBind's.
-sccEvBinds :: Bag EvBind -> [SCC EvBind]
-sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
-  where
-    edges :: [ Node EvVar EvBind ]
-    edges = foldrBag ((:) . mk_node) [] bs
-
-    mk_node :: EvBind -> Node EvVar EvBind
-    mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
-      = DigraphNode b var (nonDetEltsUniqSet (evVarsOfTerm term `unionVarSet`
-                                coVarsOfType (varType var)))
-      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
-      -- is still deterministic even if the edges are in nondeterministic order
-      -- as explained in Note [Deterministic SCC] in Digraph.
-
-evVarsOfCallStack :: EvCallStack -> VarSet
-evVarsOfCallStack cs = case cs of
-  EvCsEmpty -> emptyVarSet
-  EvCsPushCall _ _ tm -> evVarsOfTerm tm
-
 evVarsOfTypeable :: EvTypeable -> VarSet
 evVarsOfTypeable ev =
   case ev of
@@ -827,7 +863,20 @@ evVarsOfTypeable ev =
     EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]
     EvTypeableTyLit e     -> evVarsOfTerm e
 
-{-
+
+{- Note [Free vars of EvFun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Finding the free vars of an EvFun is made tricky by the fact the
+bindings et_binds may be a mutable variable.  Fortunately, we
+can just squeeze by.  Here's how.
+
+* evVarsOfTerm is used only by TcSimplify.neededEvVars.
+* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the
+  ic_binds field of an Implication
+* So we can track usage via the processing for that implication,
+  (see Note [Tracking redundant constraints] in TcSimplify).
+  We can ignore usage from the EvFun altogether.
+
 ************************************************************************
 *                                                                      *
                   Pretty printing
@@ -860,11 +909,12 @@ pprHsWrapper wrap pp_thing_inside
                                               <+> pprParendCo co)]
     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
     help it (WpTyApp ty)  = no_parens  $ sep [it True, text "@" <+> pprParendType ty]
-    help it (WpEvLam id)  = add_parens $ sep [ text "\\" <> pp_bndr id, it False]
-    help it (WpTyLam tv)  = add_parens $ sep [text "/\\" <> pp_bndr tv, it False]
+    help it (WpEvLam id)  = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False]
+    help it (WpTyLam tv)  = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False]
     help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False]
 
-    pp_bndr v = pprBndr LambdaBind v <> dot
+pprLamBndr :: Id -> SDoc
+pprLamBndr v = pprBndr LambdaBind v
 
 add_parens, no_parens :: SDoc -> Bool -> SDoc
 add_parens d True  = parens d
@@ -878,9 +928,11 @@ instance Outputable TcEvBinds where
 instance Outputable EvBindsVar where
   ppr (EvBindsVar { ebv_uniq = u })
      = text "EvBindsVar" <> angleBrackets (ppr u)
+  ppr (CoEvBindsVar { ebv_uniq = u })
+     = text "CoEvBindsVar" <> angleBrackets (ppr u)
 
 instance Uniquable EvBindsVar where
-  getUnique (EvBindsVar { ebv_uniq = u }) = u
+  getUnique = ebv_uniq
 
 instance Outputable EvBind where
   ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given })
@@ -891,21 +943,11 @@ instance Outputable EvBind where
    -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
-  ppr (EvId v)              = ppr v
-  ppr (EvCast v co)         = ppr v <+> (text "`cast`") <+> pprParendCo co
-  ppr (EvCoercion co)       = text "CO" <+> ppr co
-  ppr (EvSuperClass d n)    = text "sc" <> parens (ppr (d,n))
-  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
-  ppr (EvLit l)             = ppr l
-  ppr (EvCallStack cs)      = ppr cs
-  ppr (EvDelayedError ty msg) =     text "error"
-                                <+> sep [ char '@' <> ppr ty, ppr msg ]
-  ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
-  ppr (EvSelector sel tys ts) = ppr sel <+> sep [ char '@' <> ppr tys, ppr ts]
-
-instance Outputable EvLit where
-  ppr (EvNum n) = integer n
-  ppr (EvStr s) = text (show s)
+  ppr (EvExpr e)         = ppr e
+  ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
+  ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w })
+      = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow)
+           2 (ppr bs $$ ppr w)   -- Not very pretty
 
 instance Outputable EvCallStack where
   ppr EvCsEmpty
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 0e1e8662bf..b70276da7e 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -19,6 +19,8 @@ module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
 import THNames( liftStringName, liftName )
 
@@ -43,7 +45,6 @@ import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
 import TcPat
 import TcMType
 import TcType
-import DsMonad
 import Id
 import IdInfo
 import ConLike
@@ -58,14 +59,15 @@ import TyCoRep
 import Type
 import TcEvidence
 import VarSet
+import MkId( seqId )
 import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )
 import PrimOp( tagToEnumKey )
 import PrelNames
 import DynFlags
 import SrcLoc
 import Util
-import VarEnv  ( emptyTidyEnv )
+import VarEnv  ( emptyTidyEnv, mkInScopeSet )
 import ListSetOps
 import Maybes
 import Outputable
@@ -77,7 +79,6 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Data.Function
 import Data.List
-import Data.Either
 import qualified Data.Set as Set
 
 {-
@@ -109,12 +110,10 @@ tc_poly_expr expr res_ty
     do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
 
 tc_poly_expr_nc (L loc expr) res_ty
-  = do { traceTc "tcPolyExprNC" (ppr res_ty)
+  = setSrcSpan loc $
+    do { traceTc "tcPolyExprNC" (ppr res_ty)
        ; (wrap, expr')
            <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
-              setSrcSpan loc $
-                -- NB: setSrcSpan *after* skolemising, so we get better
-                -- skolem locations
               tcExpr expr res_ty
        ; return $ L loc (mkHsWrap wrap expr') }
 
@@ -166,43 +165,43 @@ NB: The res_ty is always deeply skolemised.
 -}
 
 tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
-tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
-tcExpr (HsUnboundVar uv)  res_ty = tcUnboundId uv res_ty
+tcExpr (HsVar _ (L _ name))   res_ty = tcCheckId name res_ty
+tcExpr e@(HsUnboundVar _ uv)  res_ty = tcUnboundId e uv res_ty
 
 tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
 tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
 
-tcExpr e@(HsLit lit) res_ty
+tcExpr e@(HsLit x lit) res_ty
   = do { let lit_ty = hsLitType lit
-       ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty }
+       ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
 
-tcExpr (HsPar expr)   res_ty = do { expr' <- tcMonoExprNC expr res_ty
-                                  ; return (HsPar expr') }
+tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
+                                  ; return (HsPar x expr') }
 
-tcExpr (HsSCC src lbl expr) res_ty
+tcExpr (HsSCC x src lbl expr) res_ty
   = do { expr' <- tcMonoExpr expr res_ty
-       ; return (HsSCC src lbl expr') }
+       ; return (HsSCC x src lbl expr') }
 
-tcExpr (HsTickPragma src info srcInfo expr) res_ty
+tcExpr (HsTickPragma x src info srcInfo expr) res_ty
   = do { expr' <- tcMonoExpr expr res_ty
-       ; return (HsTickPragma src info srcInfo expr') }
+       ; return (HsTickPragma x src info srcInfo expr') }
 
-tcExpr (HsCoreAnn src lbl expr) res_ty
+tcExpr (HsCoreAnn x src lbl expr) res_ty
   = do  { expr' <- tcMonoExpr expr res_ty
-        ; return (HsCoreAnn src lbl expr') }
+        ; return (HsCoreAnn x src lbl expr') }
 
-tcExpr (HsOverLit lit) res_ty
+tcExpr (HsOverLit x lit) res_ty
   = do  { lit' <- newOverloadedLit lit res_ty
-        ; return (HsOverLit lit') }
+        ; return (HsOverLit x lit') }
 
-tcExpr (NegApp expr neg_expr) res_ty
+tcExpr (NegApp x expr neg_expr) res_ty
   = do  { (expr', neg_expr')
             <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
                \[arg_ty] ->
                tcMonoExpr expr (mkCheckExpType arg_ty)
-        ; return (NegApp expr' neg_expr') }
+        ; return (NegApp x expr' neg_expr') }
 
-tcExpr e@(HsIPVar x) res_ty
+tcExpr e@(HsIPVar _ x) res_ty
   = do {   {- Implicit parameters must have a *tau-type* not a
               type scheme.  We enforce this by creating a fresh
               type variable as its type.  (Because res_ty may not
@@ -211,15 +210,16 @@ tcExpr e@(HsIPVar x) res_ty
        ; let ip_name = mkStrLitTy (hsIPNameFS x)
        ; ipClass <- tcLookupClass ipClassName
        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
-       ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var)))
-                      ip_ty res_ty }
+       ; tcWrapResult e
+                   (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))
+                   ip_ty res_ty }
   where
   -- Coerces a dictionary for `IP "x" t` into `t`.
   fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
                           unwrapIP $ mkClassPred ipClass [x,ty]
   origin = IPOccOrigin x
 
-tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
+tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
   = do { -- See Note [Type-checking overloaded labels]
          loc <- getSrcSpanM
        ; case mb_fromLabel of
@@ -229,7 +229,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
                          ; let pred = mkClassPred isLabelClass [lbl, alpha]
                          ; loc <- getSrcSpanM
                          ; var <- emitWantedEvVar origin pred
-                         ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
+                         ; tcWrapResult e
+                                       (fromDict pred (HsVar noExt (L loc var)))
                                         alpha res_ty } }
   where
   -- Coerces a dictionary for `IsLabel "x" t` into `t`,
@@ -239,12 +240,13 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
   lbl = mkStrLitTy l
 
   applyFromLabel loc fromLabel =
-    L loc (HsVar (L loc fromLabel)) `HsAppType`
-      mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
+    HsAppType
+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+         (L loc (HsVar noExt (L loc fromLabel)))
 
-tcExpr (HsLam match) res_ty
+tcExpr (HsLam x match) res_ty
   = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
-        ; return (mkHsWrap wrap (HsLam match')) }
+        ; return (mkHsWrap wrap (HsLam x match')) }
   where
     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
     herald = sep [ text "The lambda expression" <+>
@@ -253,23 +255,23 @@ tcExpr (HsLam match) res_ty
                         -- The pprSetDepth makes the abstraction print briefly
                    text "has"]
 
-tcExpr e@(HsLamCase matches) res_ty
+tcExpr e@(HsLamCase x matches) res_ty
   = do { (matches', wrap)
            <- tcMatchLambda msg match_ctxt matches res_ty
            -- The laziness annotation is because we don't want to fail here
            -- if there are multiple arguments
-       ; return (mkHsWrap wrap $ HsLamCase matches') }
+       ; return (mkHsWrap wrap $ HsLamCase x matches') }
   where
     msg = sep [ text "The function" <+> quotes (ppr e)
               , text "requires"]
     match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
 
-tcExpr e@(ExprWithTySig expr sig_ty) res_ty
+tcExpr e@(ExprWithTySig sig_ty expr) res_ty
   = do { let loc = getLoc (hsSigWcType sig_ty)
        ; sig_info <- checkNoErrs $  -- Avoid error cascade
                      tcUserTypeSig loc sig_ty Nothing
        ; (expr', poly_ty) <- tcExprSig expr sig_info
-       ; let expr'' = ExprWithTySigOut expr' sig_ty
+       ; let expr'' = ExprWithTySig sig_ty expr'
        ; tcWrapResult e expr'' poly_ty res_ty }
 
 {-
@@ -348,8 +350,8 @@ construct.
 See also Note [seqId magic] in MkId
 -}
 
-tcExpr expr@(OpApp arg1 op fix arg2) res_ty
-  | (L loc (HsVar (L lv op_name))) <- op
+tcExpr expr@(OpApp fix arg1 op arg2) res_ty
+  | (L loc (HsVar _ (L lv op_name))) <- op
   , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
   = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
        ; let arg2_exp_ty = res_ty
@@ -359,10 +361,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
        ; arg2_ty <- readExpType arg2_exp_ty
        ; op_id <- tcLookupId op_name
        ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])
-                                   (HsVar (L lv op_id)))
-       ; return $ OpApp arg1' op' fix arg2' }
+                                   (HsVar noExt (L lv op_id)))
+       ; return $ OpApp fix arg1' op' arg2' }
 
-  | (L loc (HsVar (L lv op_name))) <- op
+  | (L loc (HsVar _ (L lv op_name))) <- op
   , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
   = do { traceTc "Application rule" (ppr op)
        ; (arg1', arg1_ty) <- tcInferSigma arg1
@@ -370,7 +372,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
        ; let doc   = text "The first argument of ($) takes"
              orig1 = lexprCtOrigin arg1
        ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
-           matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
+           matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty
 
          -- We have (arg1 $ arg2)
          -- So: arg1_ty = arg2_ty -> op_res_ty
@@ -385,7 +387,8 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
        --
        -- The *result* type can have any kind (Trac #8739),
        -- so we don't need to check anything for that
-       ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
+       ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))
+                        (typeKind arg2_sigma) liftedTypeKind
            -- ignore the evidence. arg2_sigma must have type * or #,
            -- because we know arg2_sigma -> or_res_ty is well-kinded
            -- (because otherwise matchActualFunTys would fail)
@@ -396,10 +399,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
 
        ; op_id  <- tcLookupId op_name
        ; res_ty <- readExpType res_ty
-       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
+       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty
                                                , arg2_sigma
                                                , res_ty])
-                                   (HsVar (L lv op_id)))
+                                   (HsVar noExt (L lv op_id)))
              -- arg1' :: arg1_ty
              -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
              -- wrap_res :: op_res_ty "->" res_ty
@@ -410,63 +413,63 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
                      <.> wrap_arg1
              doc = text "When looking at the argument to ($)"
 
-       ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
+       ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }
 
-  | (L loc (HsRecFld (Ambiguous lbl _))) <- op
+  | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op
   , Just sig_ty <- obviousSig (unLoc arg1)
     -- See Note [Disambiguating record fields]
   = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
        ; sel_name <- disambiguateSelector lbl sig_tc_ty
-       ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
-       ; tcExpr (OpApp arg1 op' fix arg2) res_ty
+       ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))
+       ; tcExpr (OpApp fix arg1 op' arg2) res_ty
        }
 
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)
-       ; (wrap, op', [Left arg1', Left arg2'])
+       ; (wrap, op', [HsValArg arg1', HsValArg arg2'])
            <- tcApp (Just $ mk_op_msg op)
-                     op [Left arg1, Left arg2] res_ty
-       ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
+                     op [HsValArg arg1, HsValArg arg2] res_ty
+       ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') }
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --      \ x -> op x expr
 
-tcExpr expr@(SectionR op arg2) res_ty
+tcExpr expr@(SectionR x op arg2) res_ty
   = do { (op', op_ty) <- tcInferFun op
        ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
-                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty
+                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                  (mkFunTy arg1_ty op_res_ty) res_ty
        ; arg2' <- tcArg op arg2 arg2_ty 2
        ; return ( mkHsWrap wrap_res $
-                  SectionR (mkLHsWrap wrap_fun op') arg2' ) }
+                  SectionR x (mkLHsWrap wrap_fun op') arg2' ) }
   where
     fn_orig = lexprCtOrigin op
     -- It's important to use the origin of 'op', so that call-stacks
     -- come out right; they are driven by the OccurrenceOf CtOrigin
     -- See Trac #13285
 
-tcExpr expr@(SectionL arg1 op) res_ty
+tcExpr expr@(SectionL x arg1 op) res_ty
   = do { (op', op_ty) <- tcInferFun op
        ; dflags <- getDynFlags      -- Note [Left sections]
        ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
                          | otherwise                            = 2
 
        ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
-           <- matchActualFunTys (mk_op_msg op) fn_orig (Just op)
+           <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))
                                 n_reqd_args op_ty
        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                  (mkFunTys arg_tys op_res_ty) res_ty
        ; arg1' <- tcArg op arg1 arg1_ty 1
        ; return ( mkHsWrap wrap_res $
-                  SectionL arg1' (mkLHsWrap wrap_fn op') ) }
+                  SectionL x arg1' (mkLHsWrap wrap_fn op') ) }
   where
     fn_orig = lexprCtOrigin op
     -- It's important to use the origin of 'op', so that call-stacks
     -- come out right; they are driven by the OccurrenceOf CtOrigin
     -- See Trac #13285
 
-tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
+tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let arity  = length tup_args
              tup_tc = tupleTyCon boxity arity
@@ -478,7 +481,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
        ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
                                        Boxed   -> arg_tys
        ; tup_args1 <- tcTupArgs tup_args arg_tys'
-       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
+       ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
 
   | otherwise
   = -- The tup_args are a mixture of Present and Missing (for tuple sections)
@@ -498,16 +501,16 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
        -- Handle tuple sections where
        ; tup_args1 <- tcTupArgs tup_args arg_tys
 
-       ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
+       ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) }
 
-tcExpr (ExplicitSum alt arity expr _) res_ty
+tcExpr (ExplicitSum _ alt arity expr) res_ty
   = do { let sum_tc = sumTyCon arity
        ; res_ty <- expTypeToType res_ty
        ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
        ; -- Drop levity vars, we don't care about them here
          let arg_tys' = drop arity arg_tys
        ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
-       ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') }
+       ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
 
 tcExpr (ExplicitList _ witness exprs) res_ty
   = case witness of
@@ -528,15 +531,6 @@ tcExpr (ExplicitList _ witness exprs) res_ty
                      ; return $ ExplicitList elt_ty (Just fln') exprs' }
      where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
-tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
-        ; exprs' <- mapM (tc_elt elt_ty) exprs
-        ; return $
-          mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
-  where
-    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-
 {-
 ************************************************************************
 *                                                                      *
@@ -545,12 +539,12 @@ tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
 ************************************************************************
 -}
 
-tcExpr (HsLet (L l binds) expr) res_ty
+tcExpr (HsLet x (L l binds) expr) res_ty
   = do  { (binds', expr') <- tcLocalBinds binds $
                              tcMonoExpr expr res_ty
-        ; return (HsLet (L l binds') expr') }
+        ; return (HsLet x (L l binds') expr') }
 
-tcExpr (HsCase scrut matches) res_ty
+tcExpr (HsCase x scrut matches) res_ty
   = do  {  -- We used to typecheck the case alternatives first.
            -- The case patterns tend to give good type info to use
            -- when typechecking the scrutinee.  For example
@@ -564,12 +558,12 @@ tcExpr (HsCase scrut matches) res_ty
 
         ; traceTc "HsCase" (ppr scrut_ty)
         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
-        ; return (HsCase scrut' matches') }
+        ; return (HsCase x scrut' matches') }
  where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = tcBody }
 
-tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+tcExpr (HsIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
        ; res_ty <- tauifyExpType res_ty
            -- Just like Note [Case branches must never infer a non-tau type]
@@ -577,9 +571,9 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
 
        ; b1' <- tcMonoExpr b1 res_ty
        ; b2' <- tcMonoExpr b2 res_ty
-       ; return (HsIf Nothing pred' b1' b2') }
+       ; return (HsIf x Nothing pred' b1' b2') }
 
-tcExpr (HsIf (Just fun) pred b1 b2) res_ty
+tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
   = do { ((pred', b1', b2'), fun')
            <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
               \ [pred_ty, b1_ty, b2_ty] ->
@@ -587,7 +581,7 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty
                  ; b1'   <- tcPolyExpr b1   b1_ty
                  ; b2'   <- tcPolyExpr b2   b2_ty
                  ; return (pred', b1', b2') }
-       ; return (HsIf (Just fun') pred' b1' b2') }
+       ; return (HsIf x (Just fun') pred' b1' b2') }
 
 tcExpr (HsMultiIf _ alts) res_ty
   = do { res_ty <- if isSingleton alts
@@ -601,13 +595,13 @@ tcExpr (HsMultiIf _ alts) res_ty
        ; return (HsMultiIf res_ty alts') }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
-tcExpr (HsDo do_or_lc stmts _) res_ty
+tcExpr (HsDo _ do_or_lc stmts) res_ty
   = do { expr' <- tcDoStmts do_or_lc stmts res_ty
        ; return expr' }
 
-tcExpr (HsProc pat cmd) res_ty
+tcExpr (HsProc x pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
-        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+        ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
 
 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
 -- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
@@ -648,7 +642,8 @@ tcExpr (HsStatic fvs expr) res_ty
         ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
         ; let wrap = mkWpTyApps [expr_ty]
         ; loc <- getSrcSpanM
-        ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
+        ; return $ mkHsWrapCo co $ HsApp noExt
+                                         (L loc $ mkHsWrap wrap fromStaticPtr)
                                          (L loc (HsStatic fvs expr'))
         }
 
@@ -682,9 +677,10 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
                 ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
                 ; return $
                   mkHsWrap res_wrap $
-                  RecordCon { rcon_con_name = L loc con_id
-                            , rcon_con_expr = mkHsWrap con_wrap con_expr
-                            , rcon_con_like = con_like
+                  RecordCon { rcon_ext = RecordConTc
+                                 { rcon_con_like = con_like
+                                 , rcon_con_expr = mkHsWrap con_wrap con_expr }
+                            , rcon_con_name = L loc con_id
                             , rcon_flds = rbinds' } } }
 
 {-
@@ -938,7 +934,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
 
         ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
                                   (Just expr) rec_res_ty res_ty
-        ; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty
+        ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty
                 -- NB: normal unification is OK here (as opposed to subsumption),
                 -- because for this to work out, both record_rho and scrut_ty have
                 -- to be normal datatypes -- no contravariant stuff can go on
@@ -969,13 +965,17 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
         -- Phew!
         ; return $
           mkHsWrap wrap_res $
-          RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
+          RecordUpd { rupd_expr
+                          = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
                     , rupd_flds = rbinds'
-                    , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
-                    , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
+                    , rupd_ext = RecordUpdTc
+                        { rupd_cons = relevant_cons
+                        , rupd_in_tys = scrut_inst_tys
+                        , rupd_out_tys = result_inst_tys
+                        , rupd_wrap = req_wrap }} }
 
-tcExpr (HsRecFld f) res_ty
-    = tcCheckRecSelId f res_ty
+tcExpr e@(HsRecFld _ f) res_ty
+    = tcCheckRecSelId e f res_ty
 
 {-
 ************************************************************************
@@ -990,35 +990,6 @@ tcExpr (HsRecFld f) res_ty
 tcExpr (ArithSeq _ witness seq) res_ty
   = tcArithSeq witness seq res_ty
 
-tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
-        ; expr1' <- tcPolyExpr expr1 elt_ty
-        ; expr2' <- tcPolyExpr expr2 elt_ty
-        ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
-        ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
-                                 (idName enumFromToP) elt_ty
-        ; return $
-          mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') }
-
-tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
-        ; expr1' <- tcPolyExpr expr1 elt_ty
-        ; expr2' <- tcPolyExpr expr2 elt_ty
-        ; expr3' <- tcPolyExpr expr3 elt_ty
-        ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
-        ; eft <- newMethodFromName (PArrSeqOrigin seq)
-                      (idName enumFromThenToP) elt_ty        -- !!!FIXME: chak
-        ; return $
-          mkHsWrapCo coi $
-          PArrSeq eft (FromThenTo expr1' expr2' expr3') }
-
-tcExpr (PArrSeq _ _) _
-  = panic "TcExpr.tcExpr: Infinite parallel array!"
-    -- the parser shouldn't have generated it and the renamer shouldn't have
-    -- let it through
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1031,16 +1002,16 @@ tcExpr (PArrSeq _ _) _
 -- Here we get rid of it and add the finalizers to the global environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
        res_ty
   = do addModFinalizersWithLclEnv mod_finalizers
        tcExpr expr res_ty
-tcExpr (HsSpliceE splice)        res_ty
+tcExpr (HsSpliceE _ splice)          res_ty
   = tcSpliceExpr splice res_ty
-tcExpr (HsBracket brack)         res_ty
-  = tcTypedBracket   brack res_ty
-tcExpr (HsRnBracketOut brack ps) res_ty
-  = tcUntypedBracket brack ps res_ty
+tcExpr e@(HsBracket _ brack)         res_ty
+  = tcTypedBracket e brack res_ty
+tcExpr e@(HsRnBracketOut _ brack ps) res_ty
+  = tcUntypedBracket e brack ps res_ty
 
 {-
 ************************************************************************
@@ -1122,19 +1093,61 @@ arithSeqEltType (Just fl) res_ty
 ************************************************************************
 -}
 
-type LHsExprArgIn  = Either (LHsExpr GhcRn) (LHsWcType GhcRn)
-type LHsExprArgOut = Either (LHsExpr GhcTcId) (LHsWcType GhcRn)
-   -- Left e   => argument expression
-   -- Right ty => visible type application
+data HsArg tm ty
+  = HsValArg tm   -- Argument is an ordinary expression     (f arg)
+  | HsTypeArg  ty -- Argument is a visible type application (f @ty)
+  | HsArgPar SrcSpan -- See Note [HsArgPar]
+
+{-
+Note [HsArgPar]
+A HsArgPar indicates that everything to the left of this in the argument list is
+enclosed in parentheses together with the function itself. It is necessary so
+that we can recreate the parenthesis structure in the original source after
+typechecking the arguments.
+
+The SrcSpan is the span of the original HsPar
+
+((f arg1) arg2 arg3) results in an input argument list of
+[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]
+
+-}
+
+wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn)
+           => LHsExpr (GhcPass id)
+           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
+           -> LHsExpr (GhcPass id)
+wrapHsArgs f []                   = f
+wrapHsArgs f (HsValArg  a : args) = wrapHsArgs (mkHsApp f a)     args
+wrapHsArgs f (HsTypeArg t : args) = wrapHsArgs (mkHsAppType f t) args
+wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args
+
+instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
+  ppr (HsValArg tm) = text "HsValArg" <> ppr tm
+  ppr (HsTypeArg ty) = text "HsTypeArg" <> ppr ty
+  ppr (HsArgPar sp) = text "HsArgPar" <> ppr sp
+
+isHsValArg :: HsArg tm ty -> Bool
+isHsValArg (HsValArg {})  = True
+isHsValArg (HsTypeArg {}) = False
+isHsValArg (HsArgPar {})  = False
+
+isArgPar :: HsArg tm ty -> Bool
+isArgPar (HsArgPar {})  = True
+isArgPar (HsValArg {})  = False
+isArgPar (HsTypeArg {}) = False
+
+isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
+isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp
+isArgPar_maybe _ = Nothing
+
+type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)
+type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)
 
 tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType
        -> ExpRhoType -> TcM (HsExpr GhcTcId)
 tcApp1 e res_ty
   = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
-       ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
-  where
-    mk_hs_app f (Left a)  = mkHsApp f a
-    mk_hs_app f (Right a) = mkHsAppTypeOut f a
+       ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) }
 
 tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
                      -- or leave out to get exactly that message
@@ -1145,66 +1158,103 @@ tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
            -- But OpApp is slightly different, so that's why the caller
            -- must assemble
 
-tcApp m_herald orig_fun orig_args res_ty
-  = go orig_fun orig_args
+tcApp m_herald (L sp (HsPar _ fun)) args res_ty
+  = tcApp m_herald fun (HsArgPar sp : args) res_ty
+
+tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
+  = tcApp m_herald fun (HsValArg arg1 : args) res_ty
+
+tcApp m_herald (L _ (HsAppType ty1 fun)) args res_ty
+  = tcApp m_herald fun (HsTypeArg ty1 : args) res_ty
+
+tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
+  | Ambiguous _ lbl        <- fld_lbl  -- Still ambiguous
+  , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first
+  , Just sig_ty     <- obviousSig arg  -- A type sig on the arg disambiguates
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name  <- disambiguateSelector lbl sig_tc_ty
+       ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)
+       ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty }
+
+tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty
+  -- Special typing rule for tagToEnum#
+  | fun_id `hasKey` tagToEnumKey
+  , n_val_args == 1
+  = tcTagToEnum loc fun_id args res_ty
+
+  -- Special typing rule for 'seq'
+  -- In the saturated case, behave as if seq had type
+  --    forall a (b::TYPE r). a -> b -> b
+  -- for some type r.  See Note [Typing rule for seq]
+  | fun_id `hasKey` seqIdKey
+  , n_val_args == 2
+  = do { rep <- newFlexiTyVarTy runtimeRepTy
+       ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]
+             seq_ty = mkSpecForAllTys [alpha,beta]
+                      (mkTyVarTy alpha `mkFunTy` mkTyVarTy beta `mkFunTy` mkTyVarTy beta)
+             seq_fun = L loc (HsVar noExt (L loc seqId))
+             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b
+             -- where 'r' is a meta type variable
+        ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }
+  where
+    n_val_args = count isHsValArg args
+
+tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] res_ty
+  -- See Note [Visible type application for the empty list constructor]
+  = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
+       ; let list_ty = TyConApp listTyCon [ty_arg']
+       ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
+                          list_ty res_ty
+       ; let expr :: LHsExpr GhcTcId
+             expr = L loc $ ExplicitList ty_arg' Nothing []
+       ; return (idHsWrapper, expr, []) }
+
+tcApp m_herald fun args res_ty
+  = do { (tc_fun, fun_ty) <- tcInferFun fun
+       ; tcFunApp m_herald fun tc_fun fun_ty args res_ty }
+
+---------------------
+tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"
+                        -- or leave out to get exactly that message
+         -> LHsExpr GhcRn                  -- Renamed function
+         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type
+         -> [LHsExprArgIn]                 -- Arguments
+         -> ExpRhoType                     -- Overall result type
+         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+            -- (wrapper-for-result, fun, args)
+            -- For an ordinary function application,
+            -- these should be assembled as wrap_res[ fun args ]
+            -- But OpApp is slightly different, so that's why the caller
+            -- must assemble
+
+-- tcFunApp deals with the general case;
+-- the special cases are handled by tcApp
+tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty
+  = do { let orig = lexprCtOrigin rn_fun
+
+       ; (wrap_fun, tc_args, actual_res_ty)
+           <- tcArgs rn_fun fun_sigma orig rn_args
+                     (m_herald `orElse` mk_app_msg rn_fun rn_args)
+
+            -- this is just like tcWrapResult, but the types don't line
+            -- up to call that function
+       ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $
+                     tcSubTypeDS_NC_O orig GenSigCtxt
+                       (Just $ unLoc $ wrapHsArgs rn_fun rn_args)
+                       actual_res_ty res_ty
+
+       ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) }
+
+mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
+mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)
+                          , text "is applied to"]
   where
-    go :: LHsExpr GhcRn -> [LHsExprArgIn]
-       -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-    go (L _ (HsPar e))       args = go e  args
-    go (L _ (HsApp e1 e2))   args = go e1 (Left e2:args)
-    go (L _ (HsAppType e t)) args = go e  (Right t:args)
-
-    go (L loc (HsVar (L _ fun))) args
-      | fun `hasKey` tagToEnumKey
-      , count isLeft args == 1
-      = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
-           ; return (wrap, expr, args) }
-
-      | fun `hasKey` seqIdKey
-      , count isLeft args == 2
-      = do { (wrap, expr, args) <- tcSeq loc fun args res_ty
-           ; return (wrap, expr, args) }
-
-    go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
-      | Just sig_ty <- obviousSig arg
-      = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
-           ; sel_name  <- disambiguateSelector lbl sig_tc_ty
-           ; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }
-
-    -- See Note [Visible type application for the empty list constructor]
-    go (L loc (ExplicitList _ Nothing [])) [Right ty_arg]
-      = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
-           ; let list_ty = TyConApp listTyCon [ty_arg']
-           ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
-                              list_ty res_ty
-           ; let expr :: LHsExpr GhcTcId
-                 expr = L loc $ ExplicitList ty_arg' Nothing []
-           ; return (idHsWrapper, expr, []) }
-
-    go fun args
-      = do {   -- Type-check the function
-           ; (fun1, fun_sigma) <- tcInferFun fun
-           ; let orig = lexprCtOrigin fun
-
-           ; (wrap_fun, args1, actual_res_ty)
-               <- tcArgs fun fun_sigma orig args
-                         (m_herald `orElse` mk_app_msg fun)
-
-                -- this is just like tcWrapResult, but the types don't line
-                -- up to call that function
-           ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
-                         tcSubTypeDS_NC_O orig GenSigCtxt
-                           (Just $ foldl mk_hs_app fun args)
-                           actual_res_ty res_ty
-
-           ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
-
-    mk_hs_app f (Left a)  = mkHsApp f a
-    mk_hs_app f (Right a) = mkHsAppType f a
-
-mk_app_msg :: LHsExpr GhcRn -> SDoc
-mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
-                     , text "is applied to"]
+    what | null type_app_args = "function"
+         | otherwise          = "expression"
+    -- Include visible type arguments (but not other arguments) in the herald.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    expr = mkHsAppTypes fun type_app_args
+    type_app_args = [hs_ty | HsTypeArg hs_ty <- args]
 
 mk_op_msg :: LHsExpr GhcRn -> SDoc
 mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
@@ -1232,12 +1282,12 @@ which is better than before.
 ----------------
 tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
 -- Infer type of a function
-tcInferFun (L loc (HsVar (L _ name)))
+tcInferFun (L loc (HsVar _ (L _ name)))
   = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
 
-tcInferFun (L loc (HsRecFld f))
+tcInferFun (L loc (HsRecFld _ f))
   = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
@@ -1261,11 +1311,20 @@ tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)
 tcArgs fun orig_fun_ty fun_orig orig_args herald
   = go [] 1 orig_fun_ty orig_args
   where
-    orig_arity = length orig_args
+    -- Don't count visible type arguments when determining how many arguments
+    -- an expression is given in an arity mismatch error, since visible type
+    -- arguments reported as a part of the expression herald itself.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    orig_expr_args_arity = count isHsValArg orig_args
 
     go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
 
-    go acc_args n fun_ty (Right hs_ty_arg:args)
+    go acc_args n fun_ty (HsArgPar sp : args)
+      = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args
+           ; return (inner_wrap, HsArgPar sp : args', res_ty)
+           }
+
+    go acc_args n fun_ty (HsTypeArg hs_ty_arg : args)
       = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
                -- wrap1 :: fun_ty "->" upsilon_ty
            ; case tcSplitForAllTy_maybe upsilon_ty of
@@ -1278,27 +1337,40 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
                                 , ppr inner_ty, pprTyVar tv
                                 , ppr vis ]) )
                     ; ty_arg <- tcHsTypeApp hs_ty_arg kind
-                    ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty
+
+                    ; inner_ty <- zonkTcType inner_ty
+                          -- See Note [Visible type application zonk]
+
+                    ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])
+                          insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty
+                                      -- NB: tv and ty_arg have the same kind, so this
+                                      --     substitution is kind-respecting
+                    ; traceTc "VTA" (vcat [ppr tv, debugPprType kind
+                                          , debugPprType ty_arg
+                                          , debugPprType (typeKind ty_arg)
+                                          , debugPprType inner_ty
+                                          , debugPprType insted_ty ])
+
                     ; (inner_wrap, args', res_ty)
                         <- go acc_args (n+1) insted_ty args
                    -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
                     ; let inst_wrap = mkWpTyApps [ty_arg]
                     ; return ( inner_wrap <.> inst_wrap <.> wrap1
-                             , Right hs_ty_arg : args'
+                             , HsTypeArg hs_ty_arg : args'
                              , res_ty ) }
                _ -> ty_app_err upsilon_ty hs_ty_arg }
 
-    go acc_args n fun_ty (Left arg : args)
+    go acc_args n fun_ty (HsValArg arg : args)
       = do { (wrap, [arg_ty], res_ty)
-               <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
-                                        acc_args orig_arity
+               <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty
+                                        acc_args orig_expr_args_arity
                -- wrap :: fun_ty "->" arg_ty -> res_ty
            ; arg' <- tcArg fun arg arg_ty n
            ; (inner_wrap, args', inner_res_ty)
                <- go (arg_ty : acc_args) (n+1) res_ty args
                -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
            ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap
-                    , Left arg' : args'
+                    , HsValArg arg' : args'
                     , inner_res_ty ) }
       where
         doc = text "When checking the" <+> speakNth n <+>
@@ -1310,6 +1382,35 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
                text "Cannot apply expression of type" <+> quotes (ppr ty) $$
                text "to a visible type argument" <+> quotes (ppr arg) }
 
+{- Note [Visible type application zonk]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).
+
+* tcHsTypeApp only guarantees that
+    - ty_arg is zonked
+    - kind(zonk(tv)) = kind(ty_arg)
+  (checkExpectedKind zonks as it goes).
+
+So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
+and inner_ty.  Otherwise we can build an ill-kinded type.  An example was
+Trac #14158, where we had:
+   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
+and we had the visible type application
+  id @(->)
+
+* We instantiated k := kappa, yielding
+    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
+* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
+* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
+  Here q1 :: RuntimeRep
+* Now we substitute
+     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
+  but we must first zonk the inner_ty to get
+      forall (a :: TYPE q1). cat a a
+  so that the result of substitution is well-kinded
+  Failing to do so led to Trac #14158.
+-}
+
 ----------------
 tcArg :: LHsExpr GhcRn                   -- The function (for error messages)
       -> LHsExpr GhcRn                   -- Actual arguments
@@ -1325,8 +1426,9 @@ tcTupArgs args tys
   = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
   where
     go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))
-    go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
-                                         ; return (L l (Present expr')) }
+    go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (L l (Present x expr')) }
+    go (L _ (XTupArg{}), _) = panic "tcTupArgs"
 
 ---------------------------
 -- See TcType.SyntaxOpType also for commentary
@@ -1349,7 +1451,7 @@ tcSyntaxOpGen :: CtOrigin
               -> SyntaxOpType
               -> ([TcSigmaType] -> TcM a)
               -> TcM (a, SyntaxExpr GhcTcId)
-tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
+tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar _ (L _ op) })
               arg_tys res_ty thing_inside
   = do { (expr, sigma) <- tcInferId op
        ; (result, expr_wrap, arg_wraps, res_wrap)
@@ -1449,7 +1551,7 @@ tcSynArgA :: CtOrigin
             -- and a wrapper to be applied to the overall expression
 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
   = do { (match_wrapper, arg_tys, res_ty)
-           <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty
+           <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty
               -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
        ; ((result, res_wrapper), arg_wrappers)
            <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
@@ -1534,10 +1636,14 @@ tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
   = setSrcSpan loc $   -- Sets the location for the implication constraint
     do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
        ; given <- newEvVars theta
+       ; traceTc "tcExprSig: CompleteSig" $
+         vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id)
+              , text "tv_prs:" <+> ppr tv_prs ]
+
        ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs
              skol_tvs  = map snd tv_prs
        ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
-                              tcExtendTyVarEnv2 tv_prs $
+                              tcExtendNameTyVarEnv tv_prs $
                               tcPolyExprNC expr tau
 
        ; let poly_wrap = mkWpTyLams   skol_tvs
@@ -1550,8 +1656,8 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
     do { (tclvl, wanted, (expr', sig_inst))
              <- pushLevelAndCaptureConstraints  $
                 do { sig_inst <- tcInstSig sig
-                   ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $
-                              tcExtendTyVarEnv2 (sig_inst_wcs   sig_inst) $
+                   ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $
+                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $
                               tcPolyExprNC expr (sig_inst_tau sig_inst)
                    ; return (expr', sig_inst) }
        -- See Note [Partial expression signatures]
@@ -1561,7 +1667,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
                         = ApplyMR
                         | otherwise
                         = NoRestrictions
-       ; (qtvs, givens, ev_binds)
+       ; (qtvs, givens, ev_binds, _)
                  <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
        ; tau <- zonkTcType tau
        ; let inferred_theta = map evVarPred givens
@@ -1622,27 +1728,31 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
 tcCheckId name res_ty
   = do { (expr, actual_res_ty) <- tcInferId name
        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
-       ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
-         tcWrapResultO (OccurrenceOf name)  expr actual_res_ty res_ty }
+       ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr
+                                                          actual_res_ty res_ty }
 
-tcCheckRecSelId :: AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
-tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
+tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty
   = do { (expr, actual_res_ty) <- tcInferRecSelId f
-       ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
-         tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
-tcCheckRecSelId (Ambiguous lbl _) res_ty
+       ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }
+tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty
   = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
       Nothing       -> ambiguousSelector lbl
       Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
-                          ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
+                          ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)
+                                                    res_ty }
+tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"
 
 ------------------------
 tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
-tcInferRecSelId (Unambiguous (L _ lbl) sel)
+tcInferRecSelId (Unambiguous sel (L _ lbl))
   = do { (expr', ty) <- tc_infer_id lbl sel
        ; return (expr', ty) }
-tcInferRecSelId (Ambiguous lbl _)
+tcInferRecSelId (Ambiguous _ lbl)
   = ambiguousSelector lbl
+tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"
 
 ------------------------
 tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
@@ -1671,7 +1781,7 @@ tc_infer_assert assert_name
   = do { assert_error_id <- tcLookupId assertErrorName
        ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
                                           (idType assert_error_id)
-       ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)
        }
 
 tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
@@ -1697,12 +1807,12 @@ tc_infer_id lbl id_name
              _ -> failWithTc $
                   ppr thing <+> text "used where a value identifier was expected" }
   where
-    return_id id = return (HsVar (noLoc id), idType id)
+    return_id id = return (HsVar noExt (noLoc id), idType id)
 
     return_data_con con
        -- For data constructors, must perform the stupid-theta check
       | null stupid_theta
-      = return (HsConLikeOut (RealDataCon con), con_ty)
+      = return (HsConLikeOut noExt (RealDataCon con), con_ty)
 
       | otherwise
        -- See Note [Instantiating stupid theta]
@@ -1713,7 +1823,8 @@ tc_infer_id lbl id_name
                  rho'   = substTy subst rho
            ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
            ; addDataConStupidTheta con tys'
-           ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') }
+           ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))
+                    , rho') }
 
       where
         con_ty         = dataConUserType con
@@ -1724,7 +1835,7 @@ tc_infer_id lbl id_name
       | otherwise                  = return ()
 
 
-tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
 -- Typecheck an occurrence of an unbound Id
 --
 -- Some of these started life as a true expression hole "_".
@@ -1733,7 +1844,7 @@ tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
 -- not unbound any more!
-tcUnboundId unbound res_ty
+tcUnboundId rn_expr unbound res_ty
  = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (Trac #12531)
       ; let occ = unboundVarOcc unbound
       ; name <- newSysName occ
@@ -1745,7 +1856,8 @@ tcUnboundId unbound res_ty
                                               , ctev_loc  = loc}
                            , cc_hole = ExprHole unbound }
       ; emitInsoluble can
-      ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }
+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))
+                                                                     ty res_ty }
 
 
 {-
@@ -1798,39 +1910,6 @@ the users that complain.
 
 -}
 
-tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
-      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
--- (seq e1 e2) :: res_ty
--- We need a special typing rule because res_ty can be unboxed
--- See Note [Typing rule for seq]
-tcSeq loc fun_name args res_ty
-  = do  { fun <- tcLookupId fun_name
-        ; (arg1_ty, args1) <- case args of
-            (Right hs_ty_arg1 : args1)
-              -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
-                    ; return (ty_arg1, args1) }
-
-            _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind
-                    ; return (arg_ty1, args) }
-
-        ; (arg1, arg2, arg2_exp_ty) <- case args1 of
-            [Right hs_ty_arg2, Left term_arg1, Left term_arg2]
-              -> do { arg2_kind <- newOpenTypeKind
-                    ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 arg2_kind
-                                   -- see Note [Typing rule for seq]
-                    ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg2 res_ty
-                    ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
-            [Left term_arg1, Left term_arg2]
-              -> return (term_arg1, term_arg2, res_ty)
-            _ -> too_many_args "seq" args
-
-        ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
-        ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
-        ; res_ty <- readExpType res_ty  -- by now, it's surely filled in
-        ; let fun'    = L loc (mkHsWrap ty_args (HsVar (L loc fun)))
-              ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
-        ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
-
 tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
             -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
 -- tagToEnum# :: forall a. Int# -> a
@@ -1838,16 +1917,21 @@ tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
 tcTagToEnum loc fun_name args res_ty
   = do { fun <- tcLookupId fun_name
 
-       ; arg <- case args of
-           [Right hs_ty_arg, Left term_arg]
+       ; let pars1 = mapMaybe isArgPar_maybe before
+             pars2 = mapMaybe isArgPar_maybe after
+             -- args contains exactly one HsValArg
+             (before, _:after) = break isHsValArg args
+
+       ; arg <- case filterOut isArgPar args of
+           [HsTypeArg hs_ty_arg, HsValArg term_arg]
              -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
                    ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
                      -- other than influencing res_ty, we just
                      -- don't care about a type arg passed in.
                      -- So drop the evidence.
                    ; return term_arg }
-           [Left term_arg] -> do { _ <- expTypeToType res_ty
-                                 ; return term_arg }
+           [HsValArg term_arg] -> do { _ <- expTypeToType res_ty
+                                     ; return term_arg }
            _          -> too_many_args "tagToEnum#" args
 
        ; res_ty <- readExpType res_ty
@@ -1869,10 +1953,15 @@ tcTagToEnum loc fun_name args res_ty
                  (mk_error ty' doc2)
 
        ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
-       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
+       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))
              rep_ty = mkTyConApp rep_tc rep_args
+             out_args = concat
+              [ pars1
+              , [HsValArg arg']
+              , pars2
+              ]
 
-       ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
+       ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) }
                  -- coi is a Representational coercion
   where
     doc1 = vcat [ text "Specify the type by giving a type signature"
@@ -1891,8 +1980,10 @@ too_many_args fun args
     hang (text "Too many type arguments to" <+> text fun <> colon)
        2 (sep (map pp args))
   where
-    pp (Left e)                             = ppr e
-    pp (Right (HsWC { hswc_body = L _ t })) = pprHsType t
+    pp (HsValArg e)                             = ppr e
+    pp (HsTypeArg (HsWC { hswc_body = L _ t })) = pprHsType t
+    pp (HsTypeArg (XHsWildCardBndrs _)) = panic "too_many_args"
+    pp (HsArgPar _) = empty
 
 
 {-
@@ -1947,7 +2038,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
         ; lift <- if isStringTy id_ty then
                      do { sid <- tcLookupId THNames.liftStringName
                                      -- See Note [Lifting strings]
-                        ; return (HsVar (noLoc sid)) }
+                        ; return (HsVar noExt (noLoc sid)) }
                   else
                      setConstraintVar lie_var   $
                           -- Put the 'lift' constraint into the right LIE
@@ -2157,8 +2248,9 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
     -- Extract the selector name of a field update if it is unambiguous
     isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
     isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
-                        Unambiguous _ sel_name -> Just (x, sel_name)
+                        Unambiguous sel_name _ -> Just (x, sel_name)
                         Ambiguous{}            -> Nothing
+                        XAmbiguousFieldOcc{}   -> Nothing
 
     -- Look up the possible parents and selector GREs for each field
     getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
@@ -2226,7 +2318,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
            ; let L loc af = hsRecFieldLbl upd
                  lbl      = rdrNameAmbiguousFieldOcc af
            ; return $ L l upd { hsRecFieldLbl
-                                  = L loc (Unambiguous (L loc lbl) i) } }
+                                  = L loc (Unambiguous i (L loc lbl)) } }
 
 
 -- Extract the outermost TyCon of a type, if there is one; for
@@ -2262,8 +2354,8 @@ lookupParents rdr
 -- the record expression in an update must be "obvious", i.e. the
 -- outermost constructor ignoring parentheses.
 obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
-obviousSig (ExprWithTySig _ ty) = Just ty
-obviousSig (HsPar p)            = obviousSig (unLoc p)
+obviousSig (ExprWithTySig ty _) = Just ty
+obviousSig (HsPar _ p)          = obviousSig (unLoc p)
 obviousSig _                    = Nothing
 
 
@@ -2295,7 +2387,7 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
   = do  { mb_binds <- mapM do_bind rbinds
         ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
-    fields = map flLabel $ conLikeFieldLabels con_like
+    fields = map flSelector $ conLikeFieldLabels con_like
     flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
 
     do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
@@ -2317,7 +2409,8 @@ tcRecordUpd
 
 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
   where
-    flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
 
     do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
             -> TcM (Maybe (LHsRecUpdField GhcTcId))
@@ -2325,22 +2418,23 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
                                  , hsRecFieldArg = rhs }))
       = do { let lbl = rdrNameAmbiguousFieldOcc af
                  sel_id = selectorAmbiguousFieldOcc af
-                 f = L loc (FieldOcc (L loc lbl) (idName sel_id))
+                 f = L loc (FieldOcc (idName sel_id) (L loc lbl))
            ; mb <- tcRecordField con_like flds_w_tys f rhs
            ; case mb of
                Nothing         -> return Nothing
                Just (f', rhs') ->
                  return (Just
                          (L l (fld { hsRecFieldLbl
-                                      = L loc (Unambiguous (L loc lbl)
-                                               (selectorFieldOcc (unLoc f')))
+                                      = L loc (Unambiguous
+                                               (extFieldOcc (unLoc f'))
+                                               (L loc lbl))
                                    , hsRecFieldArg = rhs' }))) }
 
-tcRecordField :: ConLike -> Assoc FieldLabelString Type
+tcRecordField :: ConLike -> Assoc Name Type
               -> LFieldOcc GhcRn -> LHsExpr GhcRn
               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
-  | Just field_ty <- assocMaybe flds_w_tys field_lbl
+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
+  | Just field_ty <- assocMaybe flds_w_tys sel_name
       = addErrCtxt (fieldCtxt field_lbl) $
         do { rhs' <- tcPolyExprNC rhs field_ty
            ; let field_id = mkUserLocal (nameOccName sel_name)
@@ -2350,12 +2444,13 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
                 --          (so we can find it easily)
                 --      but is a LocalId with the appropriate type of the RHS
                 --          (so the desugarer knows the type of local binder to make)
-           ; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
+           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
       | otherwise
       = do { addErrTc (badFieldCon con_like field_lbl)
            ; return Nothing }
   where
         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"
 
 
 checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()
@@ -2365,17 +2460,20 @@ checkMissingFields con_like rbinds
   = if any isBanged field_strs then
         -- Illegal if any arg is strict
         addErrTc (missingStrictFields con_like [])
-    else
-        return ()
+    else do
+        warn <- woptM Opt_WarnMissingFields
+        when (warn && notNull field_strs && null field_labels)
+             (warnTc (Reason Opt_WarnMissingFields) True
+                 (missingFields con_like []))
 
   | otherwise = do              -- A record
     unless (null missing_s_fields)
            (addErrTc (missingStrictFields con_like missing_s_fields))
 
     warn <- woptM Opt_WarnMissingFields
-    unless (not (warn && notNull missing_ns_fields))
-           (warnTc (Reason Opt_WarnMissingFields) True
-               (missingFields con_like missing_ns_fields))
+    when (warn && notNull missing_ns_fields)
+         (warnTc (Reason Opt_WarnMissingFields) True
+             (missingFields con_like missing_ns_fields))
 
   where
     missing_s_fields
@@ -2636,10 +2734,14 @@ missingStrictFields con fields
 
 missingFields :: ConLike -> [FieldLabelString] -> SDoc
 missingFields con fields
-  = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
-        <+> pprWithCommas ppr fields
+  = header <> rest
+  where
+    rest | null fields = Outputable.empty
+         | otherwise = colon <+> pprWithCommas ppr fields
+    header = text "Fields of" <+> quotes (ppr con) <+>
+             text "not initialised"
 
--- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))
+-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))
 
 noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
 noPossibleParents rbinds
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
index 1bb4a7165b..5c9bdd96be 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -1,34 +1,34 @@
-{-# LANGUAGE CPP, ViewPatterns #-}
+{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}
 
 module TcFlatten(
    FlattenMode(..),
-   flatten, flattenManyNom,
+   flatten, flattenKind, flattenArgsNom,
 
    unflattenWanteds
  ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes
 import TcType
 import Type
-import TcUnify( occCheckExpand )
 import TcEvidence
 import TyCon
 import TyCoRep   -- performs delicate algorithm on types
 import Coercion
 import Var
+import VarSet
 import VarEnv
 import Outputable
 import TcSMonad as TcS
 import BasicTypes( SwapFlag(..) )
 
+import Pair
 import Util
 import Bag
-import Pair
 import Control.Monad
-import MonadUtils ( zipWithAndUnzipM )
-import GHC.Exts ( inline )
 
 import Control.Arrow ( first )
 
@@ -55,14 +55,14 @@ Note [The flattening story]
 
    - A unification flatten-skolem, fmv, stands for the as-yet-unknown
      type to which (F xis) will eventually reduce.  It is filled in
-     only by dischargeFmv.
+
 
    - All fsk/fmv variables are "untouchable".  To make it simple to test,
      we simply give them TcLevel=0.  This means that in a CTyVarEq, say,
        fmv ~ Int
      we NEVER unify fmv.
 
-   - A unification flatten-skolems, fmv, ONLY gets unified when either
+   - A unification flatten-skolem, fmv, ONLY gets unified when either
        a) The CFunEqCan takes a step, using an axiom
        b) By unflattenWanteds
     They are never unified in any other form of equality.
@@ -81,15 +81,17 @@ Note [The flattening story]
    - We unflatten Wanteds at the end of each attempt to simplify the
      wanteds; see unflattenWanteds, called from solveSimpleWanteds.
 
-* Each canonical [G], [W], or [WD] CFunEqCan x : F xis ~ fsk/fmv
-  has its own distinct evidence variable x and flatten-skolem fsk/fmv.
+* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]
+       CFunEqCan x : F xis ~ fsk/fmv
+  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.
   Why? We make a fresh fsk/fmv when the constraint is born;
   and we never rewrite the RHS of a CFunEqCan.
 
-  In contrast a [D] CFunEqCan shares its fmv with its partner [W],
+  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],
   but does not "own" it.  If we reduce a [D] F Int ~ fmv, where
   say type instance F Int = ty, then we don't discharge fmv := ty.
-  Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq)
+  Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq,
+  and dischargeFmv)
 
 * Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
                        then xis1 /= xis2
@@ -450,11 +452,11 @@ wanteds, we will
 type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]
 
 data FlattenEnv
-  = FE { fe_mode    :: FlattenMode
-       , fe_loc     :: CtLoc              -- See Note [Flattener CtLoc]
-       , fe_flavour :: CtFlavour
-       , fe_eq_rel  :: EqRel              -- See Note [Flattener EqRels]
-       , fe_work    :: FlatWorkListRef }  -- See Note [The flattening work list]
+  = FE { fe_mode    :: !FlattenMode
+       , fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]
+       , fe_flavour :: !CtFlavour
+       , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]
+       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]
 
 data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
   = FM_FlattenAll          -- Postcondition: function-free
@@ -477,13 +479,6 @@ eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True
 --  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2
 eqFlattenMode _  _ = False
 
-mkFlattenEnv :: FlattenMode -> CtEvidence -> FlatWorkListRef -> FlattenEnv
-mkFlattenEnv fm ctev ref = FE { fe_mode    = fm
-                              , fe_loc     = ctEvLoc ctev
-                              , fe_flavour = ctEvFlavour ctev
-                              , fe_eq_rel  = ctEvEqRel ctev
-                              , fe_work    = ref }
-
 -- | The 'FlatM' monad is a wrapper around 'TcS' with the following
 -- extra capabilities: (1) it offers access to a 'FlattenEnv';
 -- and (2) it maintains the flattening worklist.
@@ -511,15 +506,23 @@ emitFlatWork :: Ct -> FlatM ()
 -- See Note [The flattening work list]
 emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
 
-runFlatten :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
+-- convenient wrapper when you have a CtEvidence describing
+-- the flattening operation
+runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv mode ev
+  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
+
 -- Run thing_inside (which does flattening), and put all
 -- the work it generates onto the main work list
 -- See Note [The flattening work list]
--- NB: The returned evidence is always the same as the original, but with
--- perhaps a new CtLoc
-runFlatten mode ev thing_inside
+runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+runFlatten mode loc flav eq_rel thing_inside
   = do { flat_ref <- newTcRef []
-       ; let fmode = mkFlattenEnv mode ev flat_ref
+       ; let fmode = FE { fe_mode = mode
+                        , fe_loc  = loc
+                        , fe_flavour = flav
+                        , fe_eq_rel = eq_rel
+                        , fe_work = flat_ref }
        ; res <- runFlatM thing_inside fmode
        ; new_flats <- readTcRef flat_ref
        ; updWorkListTcS (add_flats new_flats)
@@ -583,21 +586,26 @@ setMode new_mode thing_inside
     then runFlatM thing_inside env
     else runFlatM thing_inside (env { fe_mode = new_mode })
 
--- | Use when flattening kinds/kind coercions. See
--- Note [No derived kind equalities] in TcCanonical
-flattenKinds :: FlatM a -> FlatM a
-flattenKinds thing_inside
+-- | Make sure that flattening actually produces a coercion (in other
+-- words, make sure our flavour is not Derived)
+-- Note [No derived kind equalities]
+noBogusCoercions :: FlatM a -> FlatM a
+noBogusCoercions thing_inside
   = FlatM $ \env ->
-    let kind_flav = case fe_flavour env of
-                      Given -> Given
-                      _     -> Wanted WDeriv
+    -- No new thunk is made if the flavour hasn't changed (note the bang).
+    let !env' = case fe_flavour env of
+          Derived -> env { fe_flavour = Wanted WDeriv }
+          _       -> env
     in
-    runFlatM thing_inside (env { fe_eq_rel = NomEq, fe_flavour = kind_flav })
+    runFlatM thing_inside env'
 
 bumpDepth :: FlatM a -> FlatM a
 bumpDepth (FlatM thing_inside)
-  = FlatM $ \env -> do { let env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }
-                       ; thing_inside env' }
+  = FlatM $ \env -> do
+      -- bumpDepth can be called a lot during flattening so we force the
+      -- new env to avoid accumulating thunks.
+      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }
+      ; thing_inside env' }
 
 {-
 Note [The flattening work list]
@@ -717,6 +725,14 @@ soon throw out the phantoms when decomposing a TyConApp. (Or, the
 canonicaliser will emit an insoluble, in which case the unflattened version
 yields a better error message anyway.)
 
+Note [No derived kind equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A kind-level coercion can appear in types, via mkCastTy. So, whenever
+we are generating a coercion in a dependent context (in other words,
+in a kind) we need to make sure that our flavour is never Derived
+(as Derived constraints have no evidence). The noBogusCoercions function
+changes the flavour from Derived just for this purpose.
+
 -}
 
 {- *********************************************************************
@@ -732,21 +748,36 @@ flatten :: FlattenMode -> CtEvidence -> TcType
         -> TcS (Xi, TcCoercion)
 flatten mode ev ty
   = do { traceTcS "flatten {" (ppr mode <+> ppr ty)
-       ; (ty', co) <- runFlatten mode ev (flatten_one ty)
+       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
        ; traceTcS "flatten }" (ppr ty')
        ; return (ty', co) }
 
-flattenManyNom :: CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion])
+-- specialized to flattening kinds: never Derived, always Nominal
+-- See Note [No derived kind equalities]
+flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)
+flattenKind loc flav ty
+  = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)
+       ; let flav' = case flav of
+                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not
+                       _       -> flav
+       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
+       ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
+       ; return (ty', co) }
+
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
 -- Externally-callable, hence runFlatten
--- Flatten a bunch of types all at once; in fact they are
--- always the arguments of a saturated type-family, so
+-- Flatten a vector of types all at once; in fact they are
+-- always the arguments of type family or class, so
 --      ctEvFlavour ev = Nominal
 -- and we want to flatten all at nominal role
-flattenManyNom ev tys
-  = do { traceTcS "flatten_many {" (vcat (map ppr tys))
-       ; (tys', cos) <- runFlatten FM_FlattenAll ev (flatten_many_nom tys)
+-- The kind passed in is the kind of the type family or class, call it T
+-- The last coercion returned has type (typeKind(T xis) ~N typeKind(T tys))
+flattenArgsNom ev tc tys
+  = do { traceTcS "flatten_args {" (vcat (map ppr tys))
+       ; (tys', cos, kind_co)
+           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
        ; traceTcS "flatten }" (vcat (map ppr tys'))
-       ; return (tys', cos) }
+       ; return (tys', cos, kind_co) }
 
 
 {- *********************************************************************
@@ -764,6 +795,11 @@ flattenManyNom ev tys
          has no filled-in metavariables
       co :: xi ~ ty
 
+Key invariants:
+  (F0) co :: xi ~ zonk(ty)
+  (F1) typeKind(xi) succeeds and returns a fully zonked kind
+  (F2) typeKind(xi) `eqType` zonk(typeKind(ty))
+
 Note that it is flatten's job to flatten *every type function it sees*.
 flatten is only called on *arguments* to type functions, by canEqGiven.
 
@@ -773,9 +809,10 @@ Flattening also:
 
 Because flattening zonks and the returned coercion ("co" above) is also
 zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,
-we can rely on these facts:
+we can rely on this fact:
+
   (F1) typeKind(xi) succeeds and returns a fully zonked kind
-  (F2) co :: xi ~ zonk(ty)
+
 Note that the left-hand type of co is *always* precisely xi. The right-hand
 type may or may not be ty, however: if ty has unzonked filled-in metavariables,
 then the right-hand type of co will be the zonked version of ty.
@@ -784,45 +821,16 @@ occasionally have to explicitly zonk, when (co :: xi ~ ty) is important
 even before we zonk the whole program. For example, see the FTRNotFollowed
 case in flattenTyVar.
 
-Why have these invariants on flattening? Really, they're both to ensure
-invariant (F1), which is a Good Thing because we sometimes use typeKind
+Why have these invariants on flattening? Because we sometimes use typeKind
 during canonicalisation, and we want this kind to be zonked (e.g., see
-TcCanonical.homogeniseRhsKind). Invariant (F2) is needed solely to support
-(F1). It is relied on in one place:
-
- - The FTRNotFollowed case in flattenTyVar. Here, we have a tyvar
- that cannot be reduced any further (that is, no equality over the tyvar
- is in the inert set such that the inert equality can rewrite the constraint
- at hand, and it is not a filled-in metavariable).
- But its kind might still not be flat,
- if it mentions a type family or a variable that can be rewritten. Flattened
- types have flattened kinds (see below), so we must flatten the kind. Here is
- an example:
-
-   let kappa be a filled-in metavariable such that kappa := k.
-   [G] co :: k ~ Type
-
-   We are flattening
-     a :: kappa
-   where a is a skolem.
-
- We end up in the FTRNotFollowed case, but we need to flatten the kind kappa.
- Flattening kappa yields (Type, kind_co), where kind_co :: Type ~ k. Note that the
- right-hand type of kind_co is *not* kappa, because (F1) tells us it's zonk(kappa),
- which is k. Now, we return (a |> sym kind_co). If we are to uphold (F1), then
- the right-hand type of (sym kind_co) had better be fully zonked. In other words,
- the left-hand type of kind_co needs to be zonked... which is precisely what (F2)
- guarantees.
-
-In order to support (F2), we require that ctEvCoercion, when called on a
-zonked CtEvidence, always returns a zonked coercion. See Note [Given in
-ctEvCoercion]. This requirement comes into play in flatten_tyvar2. (I suppose
-we could move the logic from ctEvCoercion to flatten_tyvar2, but it's much
-easier to do in ctEvCoercion.)
-
-Flattening a type also means flattening its kind. In the case of a type
-variable whose kind mentions a type family, this might mean that the result
-of flattening has a cast in it.
+TcCanonical.canEqTyVar).
+
+Flattening is always homogeneous. That is, the kind of the result of flattening is
+always the same as the kind of the input, modulo zonking. More formally:
+
+  (F2) typeKind(xi) `eqType` zonk(typeKind(ty))
+
+This invariant means that the kind of a flattened type might not itself be flat.
 
 Recall that in comments we use alpha[flat = ty] to represent a
 flattening skolem variable alpha which has been generated to stand in
@@ -849,12 +857,12 @@ transitive expansion contains any type function applications.  If so,
 it expands the synonym and proceeds; if not, it simply returns the
 unexpanded synonym.
 
-Note [flatten_many performance]
+Note [flatten_args performance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In programs with lots of type-level evaluation, flatten_many becomes
+In programs with lots of type-level evaluation, flatten_args becomes
 part of a tight loop. For example, see test perf/compiler/T9872a, which
-calls flatten_many a whopping 7,106,808 times. It is thus important
-that flatten_many be efficient.
+calls flatten_args a whopping 7,106,808 times. It is thus important
+that flatten_args be efficient.
 
 Performance testing showed that the current implementation is indeed
 efficient. It's critically important that zipWithAndUnzipM be
@@ -865,8 +873,8 @@ it. On test T9872a, here are the allocation stats (Dec 16, 2014):
  * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap
  * Specialized, inlined:         6,281,539,792 bytes allocated in the heap
 
-To improve performance even further, flatten_many_nom is split off
-from flatten_many, as nominal equality is the common case. This would
+To improve performance even further, flatten_args_nom is split off
+from flatten_args, as nominal equality is the common case. This would
 be natural to write using mapAndUnzipM, but even inlined, that function
 is not as performant as a hand-written loop.
 
@@ -879,32 +887,480 @@ and T5321Fun.
 If we need to make this yet more performant, a possible way forward is to
 duplicate the flattener code for the nominal case, and make that case
 faster. This doesn't seem quite worth it, yet.
+
+Note [flatten_args]
+~~~~~~~~~~~~~~~~~~~
+Invariant (F2) of Note [Flattening] says that flattening is homogeneous.
+This causes some trouble when flattening a function applied to a telescope
+of arguments, perhaps with dependency. For example, suppose
+
+  type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k]
+
+and we wish to flatten the args of (with kind applications explicit)
+
+  F a b (Just a c) (Right a b d) False
+
+where all variables are skolems and
+
+  a :: Type
+  b :: Type
+  c :: a
+  d :: k
+
+  [G] aco :: a ~ fa
+  [G] bco :: b ~ fb
+  [G] cco :: c ~ fc
+  [G] dco :: d ~ fd
+
+We process the args in left-to-right order. The first two args are easy:
+
+  (sym aco, fa) <- flatten a
+  (sym bco, fb) <- flatten b
+
+But now consider flattening (Just a c :: Maybe a). Regardless of how this
+flattens, the result will have kind (Maybe a), due to (F2). And yet, when
+we build the application (F fa fb ...), we need this argument to have kind
+(Maybe fa), not (Maybe a). Suppose (Just a c) flattens to f3 (the "3" is
+because it's the 3rd argument). We know f3 :: Maybe a. In order to get f3
+to have kind Maybe fa, we must cast it. The coercion to use is determined
+by the kind of F: we see in F's kind that the third argument has kind
+Maybe j. Critically, we also know that the argument corresponding to j
+(in our example, a) flattened with a coercion (sym aco). We can thus
+know the coercion needed for the 3rd argument is (Maybe aco).
+
+More generally, we must use the Lifting Lemma, as implemented in
+Coercion.liftCoSubst. As we work left-to-right, any variable that is a
+dependent parameter (j and k, in our example) gets mapped in a lifting context
+to the coercion that is output from flattening the corresponding argument (aco
+and bco, in our example). Then, after flattening later arguments, we lift the
+kind of these arguments in the lifting context that we've be building up.
+This coercion is then used to keep the result of flattening well-kinded.
+
+Working through our example, this is what happens:
+
+  1. Flatten a, getting (sym aco, fa). Extend the (empty) LC with [j |-> sym aco]
+
+  2. Flatten b, getting (sym bco, fb). Extend the LC with [k |-> sym bco].
+
+  3. Flatten (Just a c), getting (co3, f3). Lifting the kind (Maybe j) with our LC
+     yields lco3 :: Maybe fa ~ Maybe a. Use (f3 |> sym lco3) as the argument to
+     F.
+
+  4. Flatten (Right a b d), getting (co4, f4). Lifting the kind (Either j k) with our LC
+     yields lco4 :: Either fa fb ~ Either a b. Use (f4 |> sym lco4) as the 4th
+     argument to F.
+
+  5. Flatten False, getting (<False>, False). We lift Bool with our LC, getting <Bool>;
+     casting has no effect. (Indeed we lifted and casted with no effect for steps 1 and 2, as well.)
+
+We're now almost done, but the new application (F fa fb (f3 |> sym lco3) (f4
+|> sym lco4) False) has the wrong kind. Its kind is [fb], instead of the original [b].
+So we must use our LC one last time to lift the result kind [k], getting res_co :: [fb] ~ [b], and
+we cast our result.
+
+Accordingly, the final result is
+
+  F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco)))
+          (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco)))
+          False
+            |> [sym bco]
+
+The res_co is returned as the third return value from flatten_args.
+
+Note [Last case in flatten_args]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In writing flatten_args's `go`, we know here that tys cannot be empty,
+because that case is first. We've run out of
+binders. But perhaps inner_ki is a tyvar that has been instantiated with a
+Π-type. I believe this, today, this Π-type must be an ordinary function.
+But tomorrow, we may allow, say, visible type application in types. And
+it's best to be prepared.
+
+Here is an example.
+
+  a :: forall (k :: Type). k -> k
+  type family Star
+  Proxy :: forall j. j -> Type
+  axStar :: Star ~ Type
+  type family NoWay :: Bool
+  axNoWay :: NoWay ~ False
+  bo :: Type
+  [G] bc :: bo ~ Bool   (in inert set)
+
+  co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)
+  co = forall (j :: sym axStar). (<j> -> sym axStar)
+
+  We are flattening:
+  a (forall (j :: Star). (j |> axStar) -> Star)   -- 1
+    (Proxy |> co)                                 -- 2
+    (bo |> sym axStar)                            -- 3
+    (NoWay |> sym bc)                             -- 4
+      :: Star
+
+Flattening (1) gives us
+    (forall j. j -> Type)
+    co1 :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)
+We also extend the lifting context with
+    k |-> co1
+
+Flattening (2) gives us
+    (Proxy |> co)
+But building (a (forall j. j -> Type) Proxy) would be ill-kinded. So we cast the
+result of flattening by sym co1, to get
+    (Proxy |> co |> sym co1)
+Happily, co and co1 cancel each other out, leaving us with
+    Proxy
+    co2 :: Proxy ~ (Proxy |> co)
+
+Now we need to flatten (3). After flattening, should we tack on a homogenizing
+coercion? The way we normally tell is to look at the kind of `a`. (See Note
+[flatten_args].) Here, the remainder of the kind of `a` that we're left with
+after processing two arguments is just `k`.
+
+The way forward is look up k in the lifting context, getting co1. If we're at
+all well-typed, co1 will be a coercion between Π-types, with enough binders on
+both sides to accommodate any remaining arguments in flatten_args. So, let's
+decompose co1 with decomposePiCos. This decomposition needs arguments to use
+to instantiate any kind parameters. Look at the type of co1. If we just
+decomposed it, we would end up with coercions whose types include j, which is
+out of scope here. Accordingly, decomposePiCos takes a list of types whose
+kinds are the *right-hand* types in the decomposed coercion. (See comments on
+decomposePiCos, which also reverses the orientation of the coercions.)
+The right-hand types are the unflattened ones -- conveniently what we have to
+hand.
+
+So we now call
+
+  decomposePiCos (forall j. j -> Type)
+                 [bo |> sym axStar, NoWay |> sym bc]
+                 co1
+
+to get
+
+  co3 :: Star ~ Type
+  co4 :: (j |> axStar) ~ (j |> co3), substituted to
+                              (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co3)
+                           == bo ~ bo
+  res_co :: Type ~ Star -- this one's not reversed in decomposePiCos
+
+We then use these casts on (3) and (4) to get
+
+  (bo |> sym axStar |> co3 :: Type)   -- (C3)
+  (NoWay |> sym bc |> co4 :: bo)      -- (C4)
+
+We can simplify to
+
+  bo                          -- (C3)
+  (NoWay |> sym bc :: bo)     -- (C4)
+
+Now, to flatten (C3) and (C4), we still need to keep track of dependency.
+We know the type of the function applied to (C3) and (C4) must be
+(forall j. j -> Type), the flattened type
+associated with k (the final type in the kind of `a`.) (We discard the lifting
+context up to this point; as we've already substituted k, the domain of the
+lifting context we used for (1) and (2), away.)
+
+We now flatten (C3) to get
+  Bool                        -- F3
+  co5 :: Bool ~ bo
+and flatten (C4) to get
+  (False |> sym bc)
+Like we did when flattening (2), we need to cast the result of flattening
+(4), by lifting the type j with a lifting context containing
+[j |-> co5]. This lifting yields co5.
+We cast the result of flattening (C4) by sym co5 (this is the normal
+cast-after-flattening; see Note [flatten_args]):
+  (False |> sym bc |> sym co5)
+which is really just
+  False                       -- F4
+  co4 :: False ~ (NoWay |> sym bc)
+
+Now, we build up the result
+
+  a (forall j. j -> Type)
+    Proxy
+    Bool
+    False
+      |> res_co
+
+Let's check whether this is well-typed. We know
+
+  a :: forall (k :: Type). k -> k
+
+  a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type
+
+  a (forall j. j -> Type)
+    Proxy
+      :: forall j. j -> Type
+
+  a (forall j. j -> Type)
+    Proxy
+    Bool
+      :: Bool -> Type
+
+  a (forall j. j -> Type)
+    Proxy
+    Bool
+    False
+      :: Type
+
+  a (forall j. j -> Type)
+    Proxy
+    Bool
+    False
+     |> res_co
+     :: Star
+
+as desired. (Why do we want Star? Because we started with something of kind Star!)
+
+Whew.
+
+Note [flatten_exact_fam_app_fully performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and Trac #15192 for the current state.
+
+The explicit pattern match in homogenise_result helps with T9872a, b, c.
+
+Still, it increases the expected allocation of T9872d by ~2%.
+
+TODO: a step-by-step replay of the refactor to analyze the performance.
+
 -}
 
-flatten_many :: [Role] -> [Type] -> FlatM ([Xi], [Coercion])
+{-# INLINE flatten_args_tc #-}
+flatten_args_tc
+  :: TyCon         -- T
+  -> [Role]        -- Role r
+  -> [Type]        -- Arg types [t1,..,tn]
+  -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]
+                   -- 1-1 corresp with [t1,..,tn]
+           , [Coercion]  -- List of arg coercions [co1,..,con]
+                         -- 1-1 corresp with [t1,..,tn]
+                         --    coi :: xi ~r ti
+           , CoercionN)  -- Result coercion, rco
+                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))
+flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
+  -- NB: TyCon kinds are always closed
+  where
+    (bndrs, named)
+      = ty_con_binders_ty_binders' (tyConBinders tc)
+    -- it's possible that the result kind has arrows (for, e.g., a type family)
+    -- so we must split it
+    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)
+    !all_bndrs                           = bndrs `chkAppend` inner_bndrs
+    !any_named_bndrs                     = named || inner_named
+    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.
+
+{-# INLINE flatten_args #-}
+flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
+                                     -- named.
+             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
+             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence
+             -> FlatM ([Xi], [Coercion], CoercionN)
 -- Coercions :: Xi ~ Type, at roles given
--- Returns True iff (no flattening happened)
--- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused,
---     we merely want (a) Given/Solved/Derived/Wanted info
---                    (b) the GivenLoc/WantedLoc for when we create new evidence
-flatten_many roles tys
--- See Note [flatten_many performance]
-  = inline zipWithAndUnzipM go roles tys
+-- Third coercion :: typeKind(fun xis) ~N typeKind(fun tys)
+-- That is, the third coercion relates the kind of some function (whose kind is
+-- passed as the first parameter) instantiated at xis to the kind of that
+-- function instantiated at the tys. This is useful in keeping flattening
+-- homoegeneous. The list of roles must be at least as long as the list of
+-- types.
+-- See Note [flatten_args]
+flatten_args orig_binders
+             any_named_bndrs
+             orig_inner_ki
+             orig_fvs
+             orig_roles
+             orig_tys
+  = if any_named_bndrs
+    then flatten_args_slow orig_binders
+                           orig_inner_ki
+                           orig_fvs
+                           orig_roles
+                           orig_tys
+    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+
+{-# INLINE flatten_args_fast #-}
+-- | fast path flatten_args, in which none of the binders are named and
+-- therefore we can avoid tracking a lifting context.
+-- There are many bang patterns in here. It's been observed that they
+-- greatly improve performance of an optimized build.
+-- The T9872 test cases are good witnesses of this fact.
+flatten_args_fast :: [TyCoBinder]
+                  -> Kind
+                  -> [Role]
+                  -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+  = fmap finish (iterate orig_tys orig_roles orig_binders)
   where
-    go Nominal          ty = setEqRel NomEq  $ flatten_one ty
-    go Representational ty = setEqRel ReprEq $ flatten_one ty
-    go Phantom          ty = -- See Note [Phantoms in the flattener]
-                             do { ty <- liftTcS $ zonkTcType ty
-                                ; return ( ty, mkReflCo Phantom ty ) }
-
--- | Like 'flatten_many', but assumes that every role is nominal.
-flatten_many_nom :: [Type] -> FlatM ([Xi], [Coercion])
-flatten_many_nom [] = return ([], [])
--- See Note [flatten_many performance]
-flatten_many_nom (ty:tys)
-  = do { (xi, co) <- flatten_one ty
-       ; (xis, cos) <- flatten_many_nom tys
-       ; return (xi:xis, co:cos) }
+
+    iterate :: [Type]
+            -> [Role]
+            -> [TyCoBinder]
+            -> FlatM ([Xi], [Coercion], [TyCoBinder])
+    iterate (ty:tys) (role:roles) (_:binders) = do
+      (xi, co) <- go role ty
+      (xis, cos, binders) <- iterate tys roles binders
+      pure (xi : xis, co : cos, binders)
+    iterate [] _ binders = pure ([], [], binders)
+    iterate _ _ _ = pprPanic
+        "flatten_args wandered into deeper water than usual" (vcat [])
+           -- This debug information is commented out because leaving it in
+           -- causes a ~2% increase in allocations in T9872{a,c,d}.
+           {-
+             (vcat [ppr orig_binders,
+                    ppr orig_inner_ki,
+                    ppr (take 10 orig_roles), -- often infinite!
+                    ppr orig_tys])
+           -}
+
+    {-# INLINE go #-}
+    go :: Role
+       -> Type
+       -> FlatM (Xi, Coercion)
+    go role ty
+      = case role of
+          -- In the slow path we bind the Xi and Coercion from the recursive
+          -- call and then use it such
+          --
+          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)
+          --       casted_xi = xi `mkCastTy` kind_co
+          --       casted_co = xi |> kind_co ~r xi ; co
+          --
+          -- but this isn't necessary:
+          --   mkTcSymCo (Refl a b) = Refl a b,
+          --   mkCastTy x (Refl _ _) = x
+          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co
+          --
+          -- Also, no need to check isAnonTyCoBinder or isNamedTyCoBinder, since
+          -- we've already established that they're all anonymous.
+          Nominal          -> setEqRel NomEq  $ flatten_one ty
+          Representational -> setEqRel ReprEq $ flatten_one ty
+          Phantom          -> -- See Note [Phantoms in the flattener]
+                              do { ty <- liftTcS $ zonkTcType ty
+                                 ; return (ty, mkReflCo Phantom ty) }
+
+
+    {-# INLINE finish #-}
+    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)
+    finish (xis, cos, binders) = (xis, cos, kind_co)
+      where
+        final_kind = mkPiTys binders orig_inner_ki
+        kind_co    = mkNomReflCo final_kind
+
+{-# INLINE flatten_args_slow #-}
+-- | Slow path, compared to flatten_args_fast, because this one must track
+-- a lifting context.
+flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
+                  -> [Role] -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
+  = go [] [] orig_lc orig_binders orig_inner_ki orig_roles orig_tys
+  where
+    orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs
+
+    go :: [Xi]        -- Xis accumulator, in reverse order
+       -> [Coercion]  -- Coercions accumulator, in reverse order
+                      -- These are in 1-to-1 correspondence
+       -> LiftingContext  -- mapping from tyvars to flattening coercions
+       -> [TyCoBinder]    -- Unsubsted binders of function's kind
+       -> Kind        -- Unsubsted result kind of function (not a Pi-type)
+       -> [Role]      -- Roles at which to flatten these ...
+       -> [Type]      -- ... unflattened types
+       -> FlatM ([Xi], [Coercion], CoercionN)
+    go acc_xis acc_cos lc binders inner_ki _ []
+      = return (reverse acc_xis, reverse acc_cos, kind_co)
+      where
+        final_kind = mkTyCoPiTys binders inner_ki
+        kind_co = liftCoSubst Nominal lc final_kind
+
+    go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) (ty:tys)
+      = do { (xi, co) <- case role of
+               Nominal          -> setEqRel NomEq $
+                                   if isNamedTyCoBinder binder
+                                   then noBogusCoercions $ flatten_one ty
+                                   else                    flatten_one ty
+
+               Representational -> ASSERT( isAnonTyCoBinder binder )
+                                   setEqRel ReprEq $ flatten_one ty
+
+               Phantom          -> -- See Note [Phantoms in the flattener]
+                                   ASSERT( isAnonTyCoBinder binder )
+                                   do { ty <- liftTcS $ zonkTcType ty
+                                      ; return (ty, mkReflCo Phantom ty) }
+
+             -- By Note [Flattening] invariant (F2),
+             -- typeKind(xi) = typeKind(ty). But, it's possible that xi will be
+             -- used as an argument to a function whose kind is different, if
+             -- earlier arguments have been flattened to new types. We thus
+             -- need a coercion (kind_co :: old_kind ~ new_kind).
+             --
+             -- The bangs here have been observed to improve performance
+             -- significantly in optimized builds.
+           ; let kind_co = mkTcSymCo $
+                   liftCoSubst Nominal lc (tyCoBinderType binder)
+                 !casted_xi = xi `mkCastTy` kind_co
+                 casted_co =  mkTcCoherenceLeftCo role xi kind_co co
+
+             -- now, extend the lifting context with the new binding
+                 !new_lc | Just tv <- tyCoBinderVar_maybe binder
+                         = extendLiftingContextAndInScope lc tv casted_co
+                         | otherwise
+                         = lc
+
+           ; go (casted_xi : acc_xis)
+                (casted_co : acc_cos)
+                new_lc
+                binders
+                inner_ki
+                roles
+                tys
+           }
+
+      -- See Note [Last case in flatten_args]
+    go acc_xis acc_cos lc [] inner_ki roles tys
+      | Just k   <- tcGetTyVar_maybe inner_ki
+      , Just co1 <- liftCoSubstTyVar lc Nominal k
+      = do { let co1_kind              = coercionKind co1
+                 (arg_cos, res_co)     = decomposePiCos co1 co1_kind tys
+                 casted_tys            = ASSERT2( equalLength tys arg_cos
+                                                , ppr tys $$ ppr arg_cos )
+                                         zipWith mkCastTy tys arg_cos
+                    -- In general decomposePiCos can return fewer cos than tys,
+                    -- but not here; see "If we're at all well-typed..."
+                    -- in Note [Last case in flatten_args].  Hence the ASSERT.
+                 zapped_lc             = zapLiftingContext lc
+                 Pair flattened_kind _ = co1_kind
+                 (bndrs, new_inner)    = splitPiTys flattened_kind
+
+           ; (xis_out, cos_out, res_co_out)
+               <- go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_tys
+           -- cos_out :: xis_out ~ casted_tys
+           -- we need to return cos :: xis_out ~ tys
+           ; let cos = zipWith3 mkTcGReflRightCo
+                                roles
+                                casted_tys
+                                (map mkTcSymCo arg_cos)
+                 cos' = zipWith mkTransCo cos_out cos
+
+           ; return (xis_out, cos', res_co_out `mkTcTransCo` res_co) }
+
+    go _ _ _ _ _ _ _ = pprPanic
+        "flatten_args wandered into deeper water than usual" (vcat [])
+           -- This debug information is commented out because leaving it in
+           -- causes a ~2% increase in allocations in T9872d.
+           -- That's independent of the analagous case in flatten_args_fast:
+           -- each of these causes a 2% increase on its own, so commenting them
+           -- both out gives a 4% decrease in T9872d.
+           {-
+
+             (vcat [ppr orig_binders,
+                    ppr orig_inner_ki,
+                    ppr (take 10 orig_roles), -- often infinite!
+                    ppr orig_tys])
+           -}
+
 ------------------
 flatten_one :: TcType -> FlatM (Xi, Coercion)
 -- Flatten a type to get rid of type function applications, returning
@@ -922,29 +1378,7 @@ flatten_one (TyVarTy tv)
   = flattenTyVar tv
 
 flatten_one (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten_one ty1
-       ; eq_rel <- getEqRel
-       ; case (eq_rel, nextRole xi1) of
-           (NomEq,  _)                -> flatten_rhs xi1 co1 NomEq
-           (ReprEq, Nominal)          -> flatten_rhs xi1 co1 NomEq
-           (ReprEq, Representational) -> flatten_rhs xi1 co1 ReprEq
-           (ReprEq, Phantom)          -> -- See Note [Phantoms in the flattener]
-             do { ty2 <- liftTcS $ zonkTcType ty2
-                ; return ( mkAppTy xi1 ty2
-                         , mkAppCo co1 (mkNomReflCo ty2)) } }
-  where
-    flatten_rhs xi1 co1 eq_rel2
-      = do { (xi2,co2) <- setEqRel eq_rel2 $ flatten_one ty2
-           ; role1 <- getRole
-           ; let role2 = eqRelRole eq_rel2
-           ; traceFlat "flatten/appty"
-                       (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$
-                        ppr xi2 $$ ppr role1 $$ ppr role2)
-
-           ; return ( mkAppTy xi1 xi2
-                    , mkTransAppCo role1 co1 xi1 ty1
-                                   role2 co2 xi2 ty2
-                                   role1 ) }  -- output should match fmode
+  = flatten_app_tys ty1 [ty2]
 
 flatten_one (TyConApp tc tys)
   -- Expand type synonyms that mention type families
@@ -987,8 +1421,8 @@ flatten_one ty@(ForAllTy {})
 
 -- We allow for-alls when, but only when, no type function
 -- applications inside the forall involve the bound type variables.
-  = do { let (bndrs, rho) = splitForAllTyVarBndrs ty
-             tvs          = binderVars bndrs
+  = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty
+             tvs           = binderVars bndrs
        ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho
                          -- Substitute only under a forall
                          -- See Note [Flattening under a forall]
@@ -996,94 +1430,126 @@ flatten_one ty@(ForAllTy {})
 
 flatten_one (CastTy ty g)
   = do { (xi, co) <- flatten_one ty
-       ; (g', _) <- flatten_co g
+       ; (g', _)   <- flatten_co g
 
-       ; return (mkCastTy xi g', castCoercionKind co g' g) }
+       ; role <- getRole
+       ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) }
 
 flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co
 
--- | "Flatten" a coercion. Really, just flatten the types that it coerces
--- between and then use transitivity. See Note [Flattening coercions]
+-- | "Flatten" a coercion. Really, just zonk it so we can uphold
+-- (F1) of Note [Flattening]
 flatten_co :: Coercion -> FlatM (Coercion, Coercion)
 flatten_co co
-  = do { co <- liftTcS $ zonkCo co  -- see Note [Zonking when flattening a coercion]
-       ; let (Pair ty1 ty2, role) = coercionKindRole co
-       ; (co1, co2) <- flattenKinds $
-                       do { (_, co1) <- flatten_one ty1
-                          ; (_, co2) <- flatten_one ty2
-                          ; return (co1, co2) }
-       ; let co' = downgradeRole role Nominal co1 `mkTransCo`
-                   co `mkTransCo`
-                   mkSymCo (downgradeRole role Nominal co2)
-             -- kco :: (ty1' ~r ty2') ~N (ty1 ~r ty2)
-             kco = mkTyConAppCo Nominal (equalityTyCon role)
-                     [ mkKindCo co1, mkKindCo co2, co1, co2 ]
-       ; traceFlat "flatten_co" (vcat [ ppr co, ppr co1, ppr co2, ppr co' ])
+  = do { co <- liftTcS $ zonkCo co
        ; env_role <- getRole
-       ; return (co', mkProofIrrelCo env_role kco co' co) }
+       ; let co' = mkTcReflCo env_role (mkCoercionTy co)
+       ; return (co, co') }
+
+-- flatten (nested) AppTys
+flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion)
+-- commoning up nested applications allows us to look up the function's kind
+-- only once. Without commoning up like this, we would spend a quadratic amount
+-- of time looking up functions' types
+flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys)
+flatten_app_tys fun_ty arg_tys
+  = do { (fun_xi, fun_co) <- flatten_one fun_ty
+       ; flatten_app_ty_args fun_xi fun_co arg_tys }
+
+-- Given a flattened function (with the coercion produced by flattening) and
+-- a bunch of unflattened arguments, flatten the arguments and apply.
+-- The coercion argument's role matches the role stored in the FlatM monad.
+--
+-- The bang patterns used here were observed to improve performance. If you
+-- wish to remove them, be sure to check for regeressions in allocations.
+flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion)
+flatten_app_ty_args fun_xi fun_co []
+  -- this will be a common case when called from flatten_fam_app, so shortcut
+  = return (fun_xi, fun_co)
+flatten_app_ty_args fun_xi fun_co arg_tys
+  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of
+           Just (tc, xis) ->
+             do { let tc_roles  = tyConRolesRepresentational tc
+                      arg_roles = dropList xis tc_roles
+                ; (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (typeKind fun_xi) arg_roles arg_tys
+
+                  -- Here, we have fun_co :: T xi1 xi2 ~ ty
+                  -- and we need to apply fun_co to the arg_cos. The problem is
+                  -- that using mkAppCo is wrong because that function expects
+                  -- its second coercion to be Nominal, and the arg_cos might
+                  -- not be. The solution is to use transitivity:
+                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>
+                ; eq_rel <- getEqRel
+                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
+                      app_co = case eq_rel of
+                        NomEq  -> mkAppCos fun_co arg_cos
+                        ReprEq -> mkTcTyConAppCo Representational tc
+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)
+                                  `mkTcTransCo`
+                                  mkAppCos fun_co (map mkNomReflCo arg_tys)
+                ; return (app_xi, app_co, kind_co) }
+           Nothing ->
+             do { (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (typeKind fun_xi) (repeat Nominal) arg_tys
+                ; let arg_xi = mkAppTys fun_xi arg_xis
+                      arg_co = mkAppCos fun_co arg_cos
+                ; return (arg_xi, arg_co, kind_co) }
+
+       ; role <- getRole
+       ; return (homogenise_result xi co role kind_co) }
 
 flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
 flatten_ty_con_app tc tys
+  = do { role <- getRole
+       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys
+       ; let tyconapp_xi = mkTyConApp tc xis
+             tyconapp_co = mkTyConAppCo role tc cos
+       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }
+
+-- Make the result of flattening homogeneous (Note [Flattening] (F2))
+homogenise_result :: Xi              -- a flattened type
+                  -> Coercion        -- :: xi ~r original ty
+                  -> Role            -- r
+                  -> CoercionN       -- kind_co :: typeKind(xi) ~N typeKind(ty)
+                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)
+                                     --   ~r original ty)
+homogenise_result xi co r kind_co
+  -- the explicit pattern match here improves the performance of T9872a, b, c by
+  -- ~2%
+  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)
+  | otherwise         = (xi `mkCastTy` kind_co
+                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)
+{-# INLINE homogenise_result #-}
+
+-- Flatten a vector (list of arguments).
+flatten_vector :: Kind   -- of the function being applied to these arguments
+               -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the
+                         -- args have?
+               -> [Type] -- the args to flatten
+               -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_vector ki roles tys
   = do { eq_rel <- getEqRel
-       ; let role = eqRelRole eq_rel
-       ; (xis, cos) <- case eq_rel of
-                         NomEq  -> flatten_many_nom tys
-                         ReprEq -> flatten_many (tyConRolesRepresentational tc) tys
-       ; return (mkTyConApp tc xis, mkTyConAppCo role tc cos) }
+       ; case eq_rel of
+           NomEq  -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  (repeat Nominal)
+                                  tys
+           ReprEq -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  roles
+                                  tys
+       }
+  where
+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
+    fvs                                = tyCoVarsOfType ki
+{-# INLINE flatten_vector #-}
 
 {-
-Note [Flattening coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Because a flattened type has a flattened kind, we also must "flatten"
-coercions as we walk through a type. Otherwise, the "from" type of
-the coercion might not match the (now flattened) kind of the type
-that it's casting. flatten_co does the work, taking a coercion of
-type (ty1 ~ ty2) and flattening it to have type (fty1 ~ fty2),
-where flatten(ty1) = fty1 and flatten(ty2) = fty2.
-
-In other words:
-
-  If  r1 is a role
-      co :: s ~r1 t
-      flatten_co co = (fco, kco)
-      r2 is the role in the FlatM
-
-  then
-      fco :: fs ~r1 ft
-      fs, ft are flattened types
-      kco :: fco ~r2 co
-
-The second return value of flatten_co is always a ProofIrrelCo. As
-such, it doesn't contain any information the caller doesn't have and
-might not be necessary in whatever comes next.
-
-Note that a flattened coercion might have unzonked metavariables or
-type functions in it -- but its *kind* will not. Instead of just flattening
-the kinds and using mkTransCo, we could actually flatten the coercion
-structurally. But doing so seems harder than simply flattening the types.
-
-Note [Zonking when flattening a coercion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The first step in flatten_co (see Note [Flattening coercions]) is to
-zonk the input. This is necessary because we want to ensure the following
-invariants (c.f. the invariants (F1) and (F2) in Note [Flattening])
-  If
-    (co', kco) <- flatten_co co
-  Then
-    (FC1) coercionKind(co') succeeds and produces a fully zonked pair of kinds
-    (FC2) kco :: co' ~ zonk(co)
-We must zonk to ensure (1). This is because fco is built by using mkTransCo
-to build up on the input co. But if the only action that happens during
-flattening ty1 and ty2 is to zonk metavariables, the coercions returned
-(co1 and co2) will be reflexive. The mkTransCo calls will drop the reflexive
-coercions and co' will be the same as co -- with unzonked kinds.
-
-These invariants are necessary to uphold (F1) and (F2) in the CastTy and
-CoercionTy cases.
-
-We zonk right at the beginning to avoid duplicating work when flattening the
-ty1 and ty2.
-
 Note [Flattening synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Not expanding synonyms aggressively improves error messages, and
@@ -1134,129 +1600,178 @@ flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
 flatten_fam_app tc tys  -- Can be over-saturated
     = ASSERT2( tys `lengthAtLeast` tyConArity tc
              , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
+
+      do { mode <- getMode
+         ; case mode of
+             { FM_SubstOnly  -> flatten_ty_con_app tc tys
+             ; FM_FlattenAll ->
+
                  -- Type functions are saturated
                  -- The type function might be *over* saturated
                  -- in which case the remaining arguments should
                  -- be dealt with by AppTys
       do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
-         ; (xi1, co1) <- flatten_exact_fam_app tc tys1
+         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1
                -- co1 :: xi1 ~ F tys1
 
-               -- all Nominal roles b/c the tycon is oversaturated
-         ; (xis_rest, cos_rest) <- flatten_many (repeat Nominal) tys_rest
-               -- cos_res :: xis_rest ~ tys_rest
-
-         ; return ( mkAppTys xi1 xis_rest   -- NB mkAppTys: rhs_xi might not be a type variable
-                                            --    cf Trac #5655
-                  , mkAppCos co1 cos_rest
-                            -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys)
-                  ) }
-
-flatten_exact_fam_app, flatten_exact_fam_app_fully ::
-  TyCon -> [TcType] -> FlatM (Xi, Coercion)
-
-flatten_exact_fam_app tc tys
-  = do { mode <- getMode
-       ; role <- getRole
-       ; case mode of
-               -- These roles are always going to be Nominal for now,
-               -- but not if #8177 is implemented
-           FM_SubstOnly -> do { let roles = tyConRolesX role tc
-                              ; (xis, cos) <- flatten_many roles tys
-                              ; return ( mkTyConApp tc xis
-                                       , mkTyConAppCo role tc cos ) }
-
-           FM_FlattenAll -> flatten_exact_fam_app_fully tc tys }
-
---       FM_Avoid tv flat_top ->
---         do { (xis, cos) <- flatten_many fmode roles tys
---            ; if flat_top || tv `elemVarSet` tyCoVarsOfTypes xis
---              then flatten_exact_fam_app_fully fmode tc tys
---              else return ( mkTyConApp tc xis
---                          , mkTcTyConAppCo (feRole fmode) tc cos ) }
+         ; flatten_app_ty_args xi1 co1 tys_rest } } }
 
+-- the [TcType] exactly saturate the TyCon
+-- See note [flatten_exact_fam_app_fully performance]
+flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
 flatten_exact_fam_app_fully tc tys
   -- See Note [Reduce type family applications eagerly]
-  = try_to_reduce tc tys False id $
-    do { -- First, flatten the arguments
-       ; (xis, cos) <- setEqRel NomEq    $
-                       flatten_many_nom tys
-       ; eq_rel   <- getEqRel
-       ; cur_flav <- getFlavour
-       ; let role   = eqRelRole eq_rel
-             ret_co = mkTyConAppCo role tc cos
-              -- ret_co :: F xis ~ F tys
-
-        -- Now, look in the cache
-       ; mb_ct <- liftTcS $ lookupFlatCache tc xis
-       ; case mb_ct of
-           Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk
-                -- flav is [G] or [WD]
-                -- See Note [Type family equations] in TcSMonad
-             | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
-             ->  -- Usable hit in the flat-cache
-                do { traceFlat "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr rhs_ty)
-                   ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
-                          -- The fsk may already have been unified, so flatten it
-                          -- fsk_co :: fsk_xi ~ fsk
-                   ; return ( fsk_xi
-                            , fsk_co `mkTransCo`
-                              maybeSubCo eq_rel (mkSymCo co) `mkTransCo`
-                              ret_co ) }
-                                    -- :: fsk_xi ~ F xis
-
-           -- Try to reduce the family application right now
-           -- See Note [Reduce type family applications eagerly]
-           _ -> try_to_reduce tc xis True (`mkTransCo` ret_co) $
-                do { loc <- getLoc
-                   ; (ev, co, fsk) <- liftTcS $ newFlattenSkolem cur_flav loc tc xis
-
-                   -- The new constraint (F xis ~ fsk) is not necessarily inert
-                   -- (e.g. the LHS may be a redex) so we must put it in the work list
-                   ; let ct = CFunEqCan { cc_ev     = ev
-                                        , cc_fun    = tc
-                                        , cc_tyargs = xis
-                                        , cc_fsk    = fsk }
-                   ; emitFlatWork ct
-
-                   ; traceFlat "flatten/flat-cache miss" $
-                         (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
-
-                   -- NB: fsk's kind is already flattend because
-                   --     the xis are flattened
-                   ; return (mkTyVarTy fsk, maybeSubCo eq_rel (mkSymCo co)
-                                            `mkTransCo` ret_co ) }
+     -- the following typeKind should never be evaluated, as it's just used in
+     -- casting, and casts by refl are dropped
+  = do { let reduce_co = mkNomReflCo (typeKind (mkTyConApp tc tys))
+       ; mOut <- try_to_reduce_nocache tc tys reduce_co id
+       ; case mOut of
+           Just out -> pure out
+           Nothing -> do
+               { -- First, flatten the arguments
+               ; (xis, cos, kind_co)
+                   <- setEqRel NomEq $  -- just do this once, instead of for
+                                        -- each arg
+                      flatten_args_tc tc (repeat Nominal) tys
+                      -- kind_co :: typeKind(F xis) ~N typeKind(F tys)
+               ; eq_rel   <- getEqRel
+               ; cur_flav <- getFlavour
+               ; let role   = eqRelRole eq_rel
+                     ret_co = mkTyConAppCo role tc cos
+                      -- ret_co :: F xis ~ F tys; might be heterogeneous
+
+                -- Now, look in the cache
+               ; mb_ct <- liftTcS $ lookupFlatCache tc xis
+               ; case mb_ct of
+                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk
+                        -- flav is [G] or [WD]
+                        -- See Note [Type family equations] in TcSMonad
+                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
+                     ->  -- Usable hit in the flat-cache
+                        do { traceFlat "flatten/flat-cache hit" $
+                               (ppr tc <+> ppr xis $$ ppr rhs_ty)
+                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
+                                  -- The fsk may already have been unified, so
+                                  -- flatten it
+                                  -- fsk_co :: fsk_xi ~ fsk
+                           ; let xi  = fsk_xi `mkCastTy` kind_co
+                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co
+                                       `mkTransCo`
+                                       maybeSubCo eq_rel (mkSymCo co)
+                                       `mkTransCo` ret_co
+                           ; return (xi, co')
+                           }
+                                            -- :: fsk_xi ~ F xis
+
+                   -- Try to reduce the family application right now
+                   -- See Note [Reduce type family applications eagerly]
+                   _ -> do { mOut <- try_to_reduce tc
+                                                   xis
+                                                   kind_co
+                                                   (`mkTransCo` ret_co)
+                           ; case mOut of
+                               Just out -> pure out
+                               Nothing -> do
+                                 { loc <- getLoc
+                                 ; (ev, co, fsk) <- liftTcS $
+                                     newFlattenSkolem cur_flav loc tc xis
+
+                                 -- The new constraint (F xis ~ fsk) is not
+                                 -- necessarily inert (e.g. the LHS may be a
+                                 -- redex) so we must put it in the work list
+                                 ; let ct = CFunEqCan { cc_ev     = ev
+                                                      , cc_fun    = tc
+                                                      , cc_tyargs = xis
+                                                      , cc_fsk    = fsk }
+                                 ; emitFlatWork ct
+
+                                 ; traceFlat "flatten/flat-cache miss" $
+                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
+
+                                 -- NB: fsk's kind is already flattened because
+                                 --     the xis are flattened
+                                 ; let fsk_ty = mkTyVarTy fsk
+                                       xi = fsk_ty `mkCastTy` kind_co
+                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeSubCo eq_rel (mkSymCo co))
+                                             `mkTransCo` ret_co
+                                 ; return (xi, co')
+                                 }
+                           }
+               }
         }
 
   where
+
+    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into
+    -- a more general definition, but it was observed that separating them
+    -- gives better performance (lower allocation numbers in T9872x).
+
     try_to_reduce :: TyCon   -- F, family tycon
                   -> [Type]  -- args, not necessarily flattened
-                  -> Bool    -- add to the flat cache?
-                  -> (   Coercion     -- :: xi ~ F args
+                  -> CoercionN -- kind_co :: typeKind(F args) ~N
+                               --            typeKind(F orig_args)
+                               -- where
+                               -- orig_args is what was passed to the outer
+                               -- function
+                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args
                       -> Coercion )   -- what to return from outer function
-                  -> FlatM (Xi, Coercion)  -- continuation upon failure
-                  -> FlatM (Xi, Coercion)
-    try_to_reduce tc tys cache update_co k
+                  -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce tc tys kind_co update_co
       = do { checkStackDepth (mkTyConApp tc tys)
            ; mb_match <- liftTcS $ matchFam tc tys
            ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
                Just (norm_co, norm_ty)
                  -> do { traceFlat "Eager T.F. reduction success" $
                          vcat [ ppr tc, ppr tys, ppr norm_ty
                               , ppr norm_co <+> dcolon
                                             <+> ppr (coercionKind norm_co)
-                              , ppr cache]
+                              ]
                        ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty
                        ; eq_rel <- getEqRel
                        ; let co = maybeSubCo eq_rel norm_co
-                                  `mkTransCo` mkSymCo final_co
+                                   `mkTransCo` mkSymCo final_co
                        ; flavour <- getFlavour
                            -- NB: only extend cache with nominal equalities
-                       ; when (cache && eq_rel == NomEq) $
+                       ; when (eq_rel == NomEq) $
                          liftTcS $
                          extendFlatCache tc tys ( co, xi, flavour )
-                       ; return ( xi, update_co $ mkSymCo co ) }
-               Nothing -> k }
+                       ; let role = eqRelRole eq_rel
+                             xi' = xi `mkCastTy` kind_co
+                             co' = update_co $
+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
+                       ; return $ Just (xi', co') }
+               Nothing -> pure Nothing }
+
+    try_to_reduce_nocache :: TyCon   -- F, family tycon
+                          -> [Type]  -- args, not necessarily flattened
+                          -> CoercionN -- kind_co :: typeKind(F args)
+                                       --            ~N typeKind(F orig_args)
+                                       -- where
+                                       -- orig_args is what was passed to the
+                                       -- outer function
+                          -> (   Coercion     -- :: (xi |> kind_co) ~ F args
+                              -> Coercion )   -- what to return from outer
+                                              -- function
+                          -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce_nocache tc tys kind_co update_co
+      = do { checkStackDepth (mkTyConApp tc tys)
+           ; mb_match <- liftTcS $ matchFam tc tys
+           ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
+               Just (norm_co, norm_ty)
+                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
+                       ; eq_rel <- getEqRel
+                       ; let co  = maybeSubCo eq_rel norm_co
+                                    `mkTransCo` mkSymCo final_co
+                             role = eqRelRole eq_rel
+                             xi' = xi `mkCastTy` kind_co
+                             co' = update_co $
+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
+                       ; return $ Just (xi', co') }
+               Nothing -> pure Nothing }
 
 {- Note [Reduce type family applications eagerly]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1324,28 +1839,12 @@ flattenTyVar tv
                    -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)
                    ; return (ty2, co2 `mkTransCo` co1) }
 
-           FTRNotFollowed   -- Done
-             -> do { let orig_kind = tyVarKind tv
-                   ; (_new_kind, kind_co) <- setMode FM_SubstOnly $
-                                             flattenKinds $
-                                             flatten_one orig_kind
-                     ; let Pair _ zonked_kind = coercionKind kind_co
-             -- NB: kind_co :: _new_kind ~ zonked_kind
-             -- But zonked_kind is not necessarily the same as orig_kind
-             -- because that may have filled-in metavars.
-             -- Moreover the returned Xi type must be well-kinded
-             -- (e.g. in canEqTyVarTyVar we use getCastedTyVar_maybe)
-             -- If you remove it, then e.g. dependent/should_fail/T11407 panics
-             -- See also Note [Flattening]
-             -- An alternative would to use (zonkTcType orig_kind),
-             -- but some simple measurements suggest that's a little slower
-                    ; let tv'    = setTyVarKind tv zonked_kind
-                          tv_ty' = mkTyVarTy tv'
-                          ty'    = tv_ty' `mkCastTy` mkSymCo kind_co
-
-                    ; role <- getRole
-                    ; return (ty', mkReflCo role tv_ty'
-                                   `mkCoherenceLeftCo` mkSymCo kind_co) } }
+           FTRNotFollowed   -- Done, but make sure the kind is zonked
+                            -- Note [Flattening] invariant (F1)
+             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv
+                   ; role <- getRole
+                   ; let ty' = mkTyVarTy tv'
+                   ; return (ty', mkTcReflCo role ty') } }
 
 flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult
 -- "Flattening" a type variable means to apply the substitution to it
@@ -1355,15 +1854,11 @@ flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult
 -- See also the documentation for FlattenTvResult
 
 flatten_tyvar1 tv
-  | not (isTcTyVar tv)             -- Happens when flatten under a (forall a. ty)
-  = return FTRNotFollowed
-          -- So ty contains references to the non-TcTyVar a
-
-  | otherwise
   = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv
-       ; role <- getRole
        ; case mb_ty of
-           Just ty -> do { traceFlat "Following filled tyvar" (ppr tv <+> equals <+> ppr ty)
+           Just ty -> do { traceFlat "Following filled tyvar"
+                             (ppr tv <+> equals <+> ppr ty)
+                         ; role <- getRole
                          ; return (FTRFollowed ty (mkReflCo role ty)) } ;
            Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)
                          ; fr <- getFlavourRole
@@ -1381,12 +1876,17 @@ flatten_tyvar2 tv fr@(_, eq_rel)
        ; case lookupDVarEnv ieqs tv of
            Just (ct:_)   -- If the first doesn't work,
                          -- the subsequent ones won't either
-             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv, cc_rhs = rhs_ty } <- ct
-             , let ct_fr = ctEvFlavourRole ctev
+             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv
+                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
+             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
              , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR
-             ->  do { traceFlat "Following inert tyvar" (ppr mode <+> ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev)
+             ->  do { traceFlat "Following inert tyvar"
+                        (ppr mode <+>
+                         ppr tv <+>
+                         equals <+>
+                         ppr rhs_ty $$ ppr ctev)
                     ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
-                          rewrite_co  = case (ctEvEqRel ctev, eq_rel) of
+                          rewrite_co  = case (ct_eq_rel, eq_rel) of
                             (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )
                                     -- if this ASSERT fails, then
                                     -- eqCanRewriteFR answered incorrectly
@@ -1405,7 +1905,7 @@ flatten_tyvar2 tv fr@(_, eq_rel)
 Note [An alternative story for the inert substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 (This entire note is just background, left here in case we ever want
- to return the the previous state of affairs)
+ to return the previous state of affairs)
 
 We used (GHC 7.8) to have this story for the inert substitution inert_eqs
 
@@ -1526,7 +2026,7 @@ unflattenWanteds tv_eqs funeqs
                -- to observe the occurs check.  Zonking will eliminate it
                -- altogether in due course
              rhs' <- zonkTcType (mkTyConApp tc xis)
-           ; case occCheckExpand fmv rhs' of
+           ; case occCheckExpand [fmv] rhs' of
                Just rhs''    -- Normal case: fill the tyvar
                  -> do { setReflEvidence ev NomEq rhs''
                        ; unflattenFmv fmv rhs''
@@ -1549,7 +2049,10 @@ unflattenWanteds tv_eqs funeqs
     unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts
     unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv
                                     , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
-      | isFmvTyVar tv   -- Previously these fmvs were untouchable,
+
+      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]
+                        --     in TcInteract
+      , isFmvTyVar tv   -- Previously these fmvs were untouchable,
                         -- but now they are touchable
                         -- NB: unlike unflattenFmv, filling a fmv here /does/
                         --     bump the unification count; it is "improvement"
@@ -1559,11 +2062,13 @@ unflattenWanteds tv_eqs funeqs
         do { is_filled <- isFilledMetaTyVar tv
            ; elim <- case is_filled of
                False -> do { traceTcS "unflatten_eq 2" (ppr ct)
-                           ; tryFill      ev eq_rel       tv rhs }
-               True  -> do { traceTcS "unflatten_eq 2" (ppr ct)
-                           ; try_fill_rhs ev eq_rel tclvl tv rhs }
-           ; if elim then return rest
-                     else return (ct `consCts` rest) }
+                           ; tryFill ev tv rhs }
+               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)
+                           ; try_fill_rhs ev tclvl tv rhs }
+           ; if elim
+             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)
+                     ; return rest }
+             else return (ct `consCts` rest) }
 
       | otherwise
       = return (ct `consCts` rest)
@@ -1571,19 +2076,19 @@ unflattenWanteds tv_eqs funeqs
     unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)
 
     ----------------
-    try_fill_rhs ev eq_rel tclvl lhs_tv rhs
+    try_fill_rhs ev tclvl lhs_tv rhs
          -- Constraint is lhs_tv ~ rhs_tv,
          -- and lhs_tv is filled, so try RHS
       | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs
                              -- co :: kind(rhs_tv) ~ kind(lhs_tv)
       , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv
-                              && not (isSigTyVar rhs_tv))
+                              && not (isTyVarTyVar rhs_tv))
                               -- LHS is a filled fmv, and so is a type
-                              -- family application, which a SigTv should
+                              -- family application, which a TyVarTv should
                               -- not unify with
       = do { is_filled <- isFilledMetaTyVar rhs_tv
            ; if is_filled then return False
-             else tryFill ev eq_rel rhs_tv
+             else tryFill ev rhs_tv
                           (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }
 
       | otherwise
@@ -1606,30 +2111,31 @@ unflattenWanteds tv_eqs funeqs
 
     finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
 
-tryFill :: CtEvidence -> EqRel -> TcTyVar -> TcType -> TcS Bool
+tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool
 -- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv
 -- If tv does not appear in 'rhs', it set tv := rhs,
 -- binds the evidence (which should be a CtWanted) to Refl<rhs>
 -- and return True.  Otherwise returns False
-tryFill ev eq_rel tv rhs
+tryFill ev tv rhs
   = ASSERT2( not (isGiven ev), ppr ev )
     do { rhs' <- zonkTcType rhs
-       ; case tcGetTyVar_maybe rhs' of {
-            Just tv' | tv == tv' -> do { setReflEvidence ev eq_rel rhs
-                                       ; return True } ;
-            _other ->
-    do { case occCheckExpand tv rhs' of
-           Just rhs''    -- Normal case: fill the tyvar
-             -> do { setReflEvidence ev eq_rel rhs''
-                   ; unifyTyVar tv rhs''
-                   ; return True }
-
-           Nothing ->  -- Occurs check
-                      return False } } }
+       ; case () of
+            _ | Just tv' <- tcGetTyVar_maybe rhs'
+              , tv == tv'   -- tv == rhs
+              -> return True
+
+            _ | Just rhs'' <- occCheckExpand [tv] rhs'
+              -> do {       -- Fill the tyvar
+                      unifyTyVar tv rhs''
+                    ; return True }
+
+            _ | otherwise   -- Occurs check
+              -> return False
+    }
 
 setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
 setReflEvidence ev eq_rel rhs
-  = setEvBindIfWanted ev (EvCoercion refl_co)
+  = setEvBindIfWanted ev (evCoercion refl_co)
   where
     refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
 
@@ -1651,3 +2157,28 @@ unsolved constraints.  The flat form will be
 
 Flatten using the fun-eqs first.
 -}
+
+-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
+-- least one named binder.
+split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)
+split_pi_tys' ty = split ty ty
+  where
+  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
+  split _       (ForAllTy b res) = let (bs, ty, _) = split res res
+                                   in  (Named b : bs, ty, True)
+  split _       (FunTy arg res)  = let (bs, ty, named) = split res res
+                                   in  (Anon arg : bs, ty, named)
+  split orig_ty _                = ([], orig_ty, False)
+{-# INLINE split_pi_tys' #-}
+
+-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff
+-- there is at least one named binder.
+ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)
+ty_con_binders_ty_binders' = foldr go ([], False)
+  where
+    go (Bndr tv (NamedTCB vis)) (bndrs, _)
+      = (Named (Bndr tv vis) : bndrs, True)
+    go (Bndr tv AnonTCB)        (bndrs, n)
+      = (Anon (tyVarKind tv)   : bndrs, n)
+    {-# INLINE go #-}
+{-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs
index 9f560311ae..8038de3d84 100644
--- a/compiler/typecheck/TcForeign.hs
+++ b/compiler/typecheck/TcForeign.hs
@@ -33,6 +33,8 @@ module TcForeign
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 
 import TcRnMonad
@@ -129,7 +131,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0
       | Just (tc, tys) <- splitTyConApp_maybe ty
       = go_tc_app rec_nts tc tys
 
-      | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty
+      | (bndrs, inner_ty) <- splitForAllVarBndrs ty
       , not (null bndrs)
       = do (coi, nty1, gres1) <- go rec_nts inner_ty
            return ( mkHomoForAllCos (binderVars bndrs) coi
@@ -261,7 +263,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
           -- we need HsType Id hence the undefined
        ; let fi_decl = ForeignImport { fd_name = L nloc id
                                      , fd_sig_ty = undefined
-                                     , fd_co = mkSymCo norm_co
+                                     , fd_i_ext = mkSymCo norm_co
                                      , fd_fi = imp_decl' }
        ; return (id, L dloc fi_decl, gres) }
 tcFImport d = pprPanic "tcFImport" (ppr d)
@@ -407,7 +409,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe
     return ( mkVarBind id rhs
            , ForeignExport { fd_name = L loc id
                            , fd_sig_ty = undefined
-                           , fd_co = norm_co, fd_fe = spec' }
+                           , fd_e_ext = norm_co, fd_fe = spec' }
            , gres)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 7e79c12ed6..1debdddd7d 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -37,6 +37,8 @@ module TcGenDeriv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnMonad
 import HsSyn
 import RdrName
@@ -124,7 +126,7 @@ possibly zero of them).  Here's an example, with both \tr{N}ullary and
        case (a1 `eqFloat#` a2) of r -> r
   for that particular test.
 
-* If there are a lot of (more than en) nullary constructors, we emit a
+* If there are a lot of (more than ten) nullary constructors, we emit a
   catch-all clause of the form:
 
       (==) a b  = case (con2tag_Foo a) of { a# ->
@@ -192,8 +194,9 @@ gen_Eq_binds loc tycon = do
               | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
 
     method_binds dflags = unitBag (eq_bind dflags)
-    eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons
-                                            ++ fall_through_eqn dflags)
+    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
+                                 (map pats_etc pat_match_cons
+                                   ++ fall_through_eqn dflags)
 
     ------------------------------------------------------------------
     pats_etc data_con
@@ -211,7 +214,9 @@ gen_Eq_binds loc tycon = do
       where
         nested_eq_expr []  [] [] = true_Expr
         nested_eq_expr tys as bs
-          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          -- Using 'foldr1' here ensures that the derived code is correctly
+          -- associated. See Trac #10859.
           where
             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 
@@ -337,7 +342,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
 gen_Ord_binds loc tycon = do
     dflags <- getDynFlags
     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
-      then ( unitBag $ mkFunBindSE 2 loc compare_RDR []
+      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
            , emptyBag)
       else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
            , aux_binds)
@@ -444,7 +449,7 @@ gen_Ord_binds loc tycon = do
                                  , mkHsCaseAlt nlWildPat (gtResult op) ]
       where
         tag     = get_tag data_con
-        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
+        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))
 
     mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
     -- First argument 'a' known to be built with K
@@ -458,7 +463,7 @@ gen_Ord_binds loc tycon = do
 
     mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
     -- Both constructors known to be nullary
-    -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
+    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
     mkTagCmp dflags op =
       untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
         unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
@@ -611,7 +616,8 @@ gen_Enum_binds loc tycon = do
              (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
                       (nlHsApps plus_RDR
                             [ nlHsVarApps intDataCon_RDR [ah_RDR]
-                            , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))]))
+                            , nlHsLit (HsInt noExt
+                                                (mkIntegralLit (-1 :: Int)))]))
 
     to_enum dflags
       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
@@ -771,7 +777,7 @@ gen_Ix_binds loc tycon = do
 
     enum_index dflags
       = mk_easy_FunBind loc unsafeIndex_RDR
-                [noLoc (AsPat (noLoc c_RDR)
+                [noLoc (AsPat noExt (noLoc c_RDR)
                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                 d_Pat] (
            untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
@@ -898,9 +904,7 @@ instance Read T where
         -- Record construction binds even more tightly than application
         do expectP (Ident "T1")
            expectP (Punc '{')
-           expectP (Ident "f1")
-           expectP (Punc '=')
-           x          <- ReadP.reset Read.readPrec
+           x          <- Read.readField "f1" (ReadP.reset readPrec)
            expectP (Punc '}')
            return (T1 { f1 = x }))
       +++
@@ -961,11 +965,15 @@ gen_Read_binds get_fixity loc tycon
     data_cons = tyConDataCons tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 
-    read_prec = mkHsVarBind loc readPrec_RDR
-                              (nlHsApp (nlHsVar parens_RDR) read_cons)
+    read_prec = mkHsVarBind loc readPrec_RDR rhs
+      where
+        rhs | null data_cons -- See Note [Read for empty data types]
+            = nlHsVar pfail_RDR
+            | otherwise
+            = nlHsApp (nlHsVar parens_RDR)
+                      (foldr1 mk_alt (read_nullary_cons ++
+                                      read_non_nullary_cons))
 
-    read_cons | null data_cons = nlHsVar pfail_RDR  -- See Note [Read for empty data types]
-              | otherwise      = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 
     read_nullary_cons
@@ -1066,21 +1074,32 @@ gen_Read_binds get_fixity loc tycon
     read_arg a ty = ASSERT( not (isUnliftedType ty) )
                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 
-    read_field lbl a = read_lbl lbl ++
-                       [read_punc "=",
-                        noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
-
-        -- When reading field labels we might encounter
-        --      a  = 3
-        --      _a = 3
-        -- or   (#) = 4
-        -- Note the parens!
-    read_lbl lbl | isSym lbl_str
-                 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
-                 | otherwise
-                 = ident_h_pat lbl_str
-                 where
-                   lbl_str = unpackFS lbl
+    -- When reading field labels we might encounter
+    --      a  = 3
+    --      _a = 3
+    -- or   (#) = 4
+    -- Note the parens!
+    read_field lbl a =
+        [noLoc
+          (mkBindStmt
+            (nlVarPat a)
+            (nlHsApp
+              read_field
+              (nlHsVarApps reset_RDR [readPrec_RDR])
+            )
+          )
+        ]
+        where
+          lbl_str = unpackFS lbl
+          mk_read_field read_field_rdr lbl
+              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
+          read_field
+              | isSym lbl_str
+              = mk_read_field readSymField_RDR lbl_str
+              | Just (ss, '#') <- snocView lbl_str -- #14918
+              = mk_read_field readFieldHash_RDR ss
+              | otherwise
+              = mk_read_field readField_RDR lbl_str
 
 {-
 ************************************************************************
@@ -1120,7 +1139,7 @@ gen_Show_binds get_fixity loc tycon
   = (unitBag shows_prec, emptyBag)
   where
     data_cons = tyConDataCons tycon
-    shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons)
+    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
     comma_space = nlHsVar showCommaSpace_RDR
 
     pats_etc data_con
@@ -1130,7 +1149,7 @@ gen_Show_binds get_fixity loc tycon
       | otherwise   =
          ([a_Pat, con_pat],
           showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
-                                 (HsInt def (mkIntegralLit con_prec_plus_one))))
+                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))
                          (nlHsPar (nested_compose_Expr show_thingies)))
         where
              data_con_RDR  = getRdrName data_con
@@ -1214,7 +1233,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
 -- | showsPrec :: Show a => Int -> a -> ShowS
 mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
 mk_showsPrec_app p x
-  = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x]
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
 
 -- | shows :: Show a => a -> ShowS
 mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -1311,7 +1330,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     genDataTyCon :: DerivStuff
     genDataTyCon        --  $dT
       = DerivHsBind (mkHsVarBind loc data_type_name rhs,
-                     L loc (TypeSig [L loc data_type_name] sig_ty))
+                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))
 
     sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
     rhs    = nlHsVar mkDataType_RDR
@@ -1321,7 +1340,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     genDataDataCon :: DataCon -> RdrName -> DerivStuff
     genDataDataCon dc constr_name       --  $cT1 etc
       = DerivHsBind (mkHsVarBind loc constr_name rhs,
-                     L loc (TypeSig [L loc constr_name] sig_ty))
+                     L loc (TypeSig noExt [L loc constr_name] sig_ty))
       where
         sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
         rhs      = nlHsApps mkConstr_RDR constr_args
@@ -1341,11 +1360,11 @@ gen_data dflags data_type_name constr_names loc rep_tc
                | otherwise = prefix_RDR
 
         ------------ gfoldl
-    gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons)
+    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
 
     gfoldl_eqn con
       = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
-                   foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
+                   foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
                    where
                      con_name ::  RdrName
                      con_name = getRdrName con
@@ -1377,7 +1396,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
         tag = dataConTag dc
 
         ------------ toConstr
-    toCon_bind = mkFunBindSE 1 loc toConstr_RDR
+    toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
                      (zipWith to_con_eqn data_cons constr_names)
     to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
 
@@ -1512,23 +1531,11 @@ makeG_d.
 -}
 
 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon
-  | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
-                       [mkMatch (mkPrefixFunRhs (L loc lift_RDR))
-                                        [nlWildPat] errorMsg_Expr
-                                        (noLoc emptyLocalBinds)])
-                     , emptyBag)
-  | otherwise = (unitBag lift_bind, emptyBag)
+gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
   where
-    -- We may want to make mkFunBindSE's error message generation general
-    -- enough to avoid needing to duplicate its logic here. On the other
-    -- hand, it may not be worth the trouble.
-    errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
-        (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
-
-    lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons)
+    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                            (map pats_etc data_cons)
     data_cons = tyConDataCons tycon
-    tycon_str = occNameString . nameOccName . tyConName $ tycon
 
     pats_etc data_con
       = ([con_pat], lift_Expr)
@@ -1562,7 +1569,7 @@ gen_Lift_binds loc tycon
 
             lift_Expr
               | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
-              | otherwise = foldl mk_appE_app conE_Expr lifted_as
+              | otherwise = foldl' mk_appE_app conE_Expr lifted_as
             (a1:a2:_) = lifted_as
 
 mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
@@ -1578,39 +1585,55 @@ mk_appE_app a b = nlHsApps appE_RDR [a, b]
 Note [Newtype-deriving instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We take every method in the original instance and `coerce` it to fit
-into the derived instance. We need a type annotation on the argument
+into the derived instance. We need type applications on the argument
 to `coerce` to make it obvious what instantiation of the method we're
 coercing from.  So from, say,
+
   class C a b where
-    op :: a -> [b] -> Int
+    op :: forall c. a -> [b] -> c -> Int
 
   newtype T x = MkT <rep-ty>
 
   instance C a <rep-ty> => C a (T x) where
-    op = coerce @ (a -> [<rep-ty>] -> Int)
-                @ (a -> [T x]      -> Int)
-                op
+    op = coerce @ (a -> [<rep-ty>] -> c -> Int)
+                @ (a -> [T x]      -> c -> Int)
+                op :: forall c. a -> [T x] -> c -> Int
+
+In addition to the type applications, we also have an explicit
+type signature on the entire RHS. This brings the method-bound variable
+`c` into scope over the two type applications.
+See Note [GND and QuantifiedConstraints] for more information on why this
+is important.
 
-Notice that we give the 'coerce' two explicitly-visible type arguments
-to say how it should be instantiated.  Recall
+Giving 'coerce' two explicitly-visible type arguments grants us finer control
+over how it should be instantiated. Recall
 
-  coerce :: Coeercible a b => a -> b
+  coerce :: Coercible a b => a -> b
 
 By giving it explicit type arguments we deal with the case where
 'op' has a higher rank type, and so we must instantiate 'coerce' with
 a polytype.  E.g.
-   class C a where op :: forall b. a -> b -> b
+
+   class C a where op :: a -> forall b. b -> b
    newtype T x = MkT <rep-ty>
    instance C <rep-ty> => C (T x) where
-     op = coerce @ (forall b. <rep-ty> -> b -> b)
-                 @ (forall b. T x -> b -> b)
-                op
+     op = coerce @ (<rep-ty> -> forall b. b -> b)
+                 @ (T x      -> forall b. b -> b)
+                op :: T x -> forall b. b -> b
+
+The use of type applications is crucial here. If we had tried using only
+explicit type signatures, like so:
 
-The type checker checks this code, and it currently requires
--XImpredicativeTypes to permit that polymorphic type instantiation,
-so we have to switch that flag on locally in TcDeriv.genInst.
+   instance C <rep-ty> => C (T x) where
+     op = coerce (op :: <rep-ty> -> forall b. b -> b)
+                     :: T x      -> forall b. b -> b
 
-See #8503 for more discussion.
+Then GHC will attempt to deeply skolemize the two type signatures, which will
+wreak havoc with the Coercible solver. Therefore, we instead use type
+applications, which do not deeply skolemize and thus avoid this issue.
+The downside is that we currently require -XImpredicativeTypes to permit this
+polymorphic type instantiation, so we have to switch that flag on locally in
+TcDeriv.genInst. See #8503 for more discussion.
 
 Note [Newtype-deriving trickiness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1631,13 +1654,98 @@ coercing opList, thus:
   instance C a => C (N a) where { op = opN }
 
   opN :: (C a, D (N a)) => N a -> N a
-  opN = coerce @(D [a]   => [a] -> [a])
-               @(D (N a) => [N a] -> [N a]
-               opList
+  opN = coerce @([a]   -> [a])
+               @([N a] -> [N a]
+               opList :: D (N a) => [N a] -> [N a]
 
 But there is no reason to suppose that (D [a]) and (D (N a))
 are inter-coercible; these instances might completely different.
 So GHC rightly rejects this code.
+
+Note [GND and QuantifiedConstraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example from #15290:
+
+  class C m where
+    join :: m (m a) -> m a
+
+  newtype T m a = MkT (m a)
+
+  deriving instance
+    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+    C (T m)
+
+The code that GHC used to generate for this was:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(forall a.   m   (m a) ->   m a)
+                  @(forall a. T m (T m a) -> T m a)
+                  join
+
+This instantiates `coerce` at a polymorphic type, a form of impredicative
+polymorphism, so we're already on thin ice. And in fact the ice breaks,
+as we'll explain:
+
+The call to `coerce` gives rise to:
+
+  Coercible (forall a.   m   (m a) ->   m a)
+            (forall a. T m (T m a) -> T m a)
+
+And that simplified to the following implication constraint:
+
+  forall a <no-ev>. m (T m a) ~R# m (m a)
+
+But because this constraint is under a `forall`, inside a type, we have to
+prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
+*must* generate a term-level evidence binding in order to instantiate the
+quantified constraint! In response, GHC currently chooses not to use such
+a quantified constraint.
+See Note [Instances in no-evidence implications] in TcInteract.
+
+But this isn't the death knell for combining QuantifiedConstraints with GND.
+On the contrary, if we generate GND bindings in a slightly different way, then
+we can avoid this situation altogether. Instead of applying `coerce` to two
+polymorphic types, we instead let an explicit type signature do the polymorphic
+instantiation, and omit the `forall`s in the type applications.
+More concretely, we generate the following code instead:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(  m   (m a) ->   m a)
+                  @(T m (T m a) -> T m a)
+                  join :: forall a. T m (T m a) -> T m a
+
+Now the visible type arguments are both monotypes, so we need do any of this
+funny quantified constraint instantiation business.
+
+You might think that that second @(T m (T m a) -> T m a) argument is redundant
+in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
+signature, but in fact leaving it off will break this example (from the
+T15290d test case):
+
+  class C a where
+    c :: Int -> forall b. b -> a
+
+  instance C Int
+
+  instance C Age where
+    c = coerce @(Int -> forall b. b -> Int)
+               c :: Int -> forall b. b -> Age
+
+That is because the explicit type signature deeply skolemizes the forall-bound
+`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
+argument of @(Int -> forall b. b -> Age) is enough to prevent this.
+
+Be aware that the use of an explicit type signature doesn't /solve/ this
+problem; it just makes it less likely to occur. For example, if a class has
+a truly higher-rank type like so:
+
+  class CProblem m where
+    op :: (forall b. ... (m b) ...) -> Int
+
+Then the same situation will arise again. But at least it won't arise for the
+common case of methods with ordinary, prenex-quantified types.
 -}
 
 gen_Newtype_binds :: SrcSpan
@@ -1663,13 +1771,16 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
                                           [] rhs_expr]
       where
         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
+        (_, _, from_tau) = tcSplitSigmaTy from_ty
+        (_, _, to_tau)   = tcSplitSigmaTy to_ty
 
         meth_RDR = getRdrName meth_id
 
         rhs_expr = nlHsVar (getRdrName coerceId)
-                                      `nlHsAppType` from_ty
-                                      `nlHsAppType` to_ty
-                                      `nlHsApp`     nlHsVar meth_RDR
+                                      `nlHsAppType`     from_tau
+                                      `nlHsAppType`     to_tau
+                                      `nlHsApp`         nlHsVar meth_RDR
+                                      `nlExprWithTySig` to_ty
 
     mk_atf_inst :: TyCon -> TcM FamInst
     mk_atf_inst fam_tc = do
@@ -1679,7 +1790,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
                                     fam_tc rep_lhs_tys rep_rhs_ty
         -- Check (c) from Note [GND and associated type families] in TcDeriv
         checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
-                           rep_cvs' rep_lhs_tys rep_rhs_ty loc
+                           rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc
         newFamInst SynFamilyInst axiom
       where
         cls_tvs     = classTyVars cls
@@ -1696,14 +1807,16 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
         (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
         rep_tvs'    = toposortTyVars rep_tvs
         rep_cvs'    = toposortTyVars rep_cvs
+        pp_lhs      = ppr (mkTyConApp fam_tc rep_lhs_tys)
 
 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
+nlHsAppType e s = noLoc (HsAppType hs_ty e)
   where
-    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
+nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
+                            $ parenthesizeHsExpr sigPrec e
   where
     hs_ty = mkLHsSigWcType (typeToLHsType s)
 
@@ -1753,11 +1866,11 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
                   -> (LHsBind GhcPs, LSig GhcPs)
 genAuxBindSpec dflags loc (DerivCon2Tag tycon)
   = (mkFunBindSE 0 loc rdr_name eqns,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     rdr_name = con2tag_RDR dflags tycon
 
-    sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
+    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
              mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
              mkParentType tycon `mkFunTy` intPrimTy
 
@@ -1779,20 +1892,20 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
   = (mkFunBindSE 0 loc rdr_name
         [([nlConVarPat intDataCon_RDR [a_RDR]],
            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     sig_ty = mkLHsSigWcType $ L loc $
-             HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+             XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
              intTy `mkFunTy` mkParentType tycon
 
     rdr_name = tag2con_RDR dflags tycon
 
 genAuxBindSpec dflags loc (DerivMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
   where
     rdr_name = maxtag_RDR dflags tycon
-    sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
+    sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
     rhs = nlHsApp (nlHsVar intDataCon_RDR)
                   (nlHsLit (HsIntPrim NoSourceText max_tag))
     max_tag =  case (tyConDataCons tycon) of
@@ -1848,7 +1961,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
 mkFunBindSE arity loc fun pats_and_exprs
   = mkRdrFunBindSE arity (L loc fun) matches
   where
-    matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
+    matches = [mkMatch (mkPrefixFunRhs (L loc fun))
+                               (map (parenthesizePat appPrec) p) e
                                (noLoc emptyLocalBinds)
               | (p,e) <-pats_and_exprs]
 
@@ -1857,6 +1971,22 @@ mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
 mkRdrFunBind fun@(L loc _fun_rdr) matches
   = L loc (mkFunBind fun matches)
 
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that uses an empty case expression for the last
+-- argument that is passes to the given function to produce the right-hand
+-- side.
+mkFunBindEC :: Arity -> SrcSpan -> RdrName
+            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+            -> [([LPat GhcPs], LHsExpr GhcPs)]
+            -> LHsBind GhcPs
+mkFunBindEC arity loc fun catch_all pats_and_exprs
+  = mkRdrFunBindEC arity catch_all (L loc fun) matches
+  where
+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
+                                (map (parenthesizePat appPrec) p) e
+                                (noLoc emptyLocalBinds)
+              | (p,e) <- pats_and_exprs ]
+
 -- | Produces a function binding. When no equations are given, it generates
 -- a binding of the given arity and an empty case expression
 -- for the last argument that it passes to the given function to produce
@@ -2076,8 +2206,8 @@ illegal_toEnum_tag tp maxtag =
                                         (nlHsLit (mkHsString ")"))))))
 
 parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
-parenify e@(L _ (HsVar _)) = e
-parenify e                 = mkHsPar e
+parenify e@(L _ (HsVar _ _)) = e
+parenify e                   = mkHsPar e
 
 -- genOpApp wraps brackets round the operator application, so that the
 -- renamer won't subsequently try to re-associate it.
@@ -2107,7 +2237,7 @@ bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) ..
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
-    true_Expr :: LHsExpr GhcPs
+    true_Expr, pure_Expr :: LHsExpr GhcPs
 a_Expr          = nlHsVar a_RDR
 b_Expr          = nlHsVar b_RDR
 c_Expr          = nlHsVar c_RDR
@@ -2117,6 +2247,7 @@ eqTag_Expr      = nlHsVar eqTag_RDR
 gtTag_Expr      = nlHsVar gtTag_RDR
 false_Expr      = nlHsVar false_RDR
 true_Expr       = nlHsVar true_RDR
+pure_Expr       = nlHsVar pure_RDR
 
 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
 a_Pat           = nlVarPat a_RDR
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index 5cb608b5f5..41d8eb858a 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -8,6 +8,8 @@ The deriving code for the Functor, Foldable, and Traversable classes
 
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module TcGenFunctor (
         FFoldType(..), functorLikeTraverse,
@@ -16,6 +18,8 @@ module TcGenFunctor (
         gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
     ) where
 
+import GhcPrelude
+
 import Bag
 import DataCon
 import FastString
@@ -388,7 +392,7 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
          -- variables in a unboxed tuple pattern match and expression as it
          -- actually needs. See Trac #12399
          (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
-    go co (ForAllTy (TvBndr v vis) x)
+    go co (ForAllTy (Bndr v vis) x)
        | isVisibleArgFlag vis = panic "unexpected visible binder"
        | v /= var && xc       = (caseForAll v xr,True)
        where (xr,xc) = go co x
@@ -432,20 +436,24 @@ foldDataConArgs ft con
 mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
             -> State [RdrName] (LHsExpr GhcPs)
 -- (mkSimpleLam fn) returns (\x. fn(x))
-mkSimpleLam lam = do
-    (n:names) <- get
-    put names
-    body <- lam (nlHsVar n)
-    return (mkHsLam [nlVarPat n] body)
+mkSimpleLam lam =
+    get >>= \case
+      n:names -> do
+        put names
+        body <- lam (nlHsVar n)
+        return (mkHsLam [nlVarPat n] body)
+      _ -> panic "mkSimpleLam"
 
 mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
              -> State [RdrName] (LHsExpr GhcPs))
              -> State [RdrName] (LHsExpr GhcPs)
-mkSimpleLam2 lam = do
-    (n1:n2:names) <- get
-    put names
-    body <- lam (nlHsVar n1) (nlHsVar n2)
-    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+mkSimpleLam2 lam =
+    get >>= \case
+      n1:n2:names -> do
+        put names
+        body <- lam (nlHsVar n1) (nlHsVar n2)
+        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+      _ -> panic "mkSimpleLam2"
 
 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
 --
@@ -932,7 +940,7 @@ gen_Traversable_binds loc tycon
         mkApCon con [] = nlHsApps pure_RDR [con]
         mkApCon con [x] = nlHsApps fmap_RDR [con,x]
         mkApCon con (x1:x2:xs) =
-            foldl appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
+            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
           where appAp x y = nlHsApps ap_RDR [x,y]
 
 -----------------------------------------------------------------------
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index a187a268fc..9da94280ce 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -14,6 +14,8 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
                       GenericKind(..),
                       gen_Generic_binds, get_gen1_constrained_tys) where
 
+import GhcPrelude
+
 import HsSyn
 import Type
 import TcType
@@ -418,7 +420,15 @@ tc_mkRepFamInsts gk tycon inst_tys =
        -- type arguments before generating the Rep/Rep1 instance, since some
        -- of the tyvars might have been instantiated when deriving.
        -- See Note [Generating a correctly typed Rep instance].
-     ; let env        = zipTyEnv tyvars inst_args
+     ; let (env_tyvars, env_inst_args)
+             = case gk_ of
+                 Gen0_ -> (tyvars, inst_args)
+                 Gen1_ last_tv
+                          -- See the "wrinkle" in
+                          -- Note [Generating a correctly typed Rep instance]
+                       -> ( last_tv : tyvars
+                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )
+           env        = zipTyEnv env_tyvars env_inst_args
            in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
            subst      = mkTvSubst in_scope env
            repTy'     = substTy  subst repTy
@@ -921,6 +931,32 @@ the tyConTyVars of the TyCon to their counterparts in the fully instantiated
 type. (For example, using T above as example, you'd map a :-> Int.) We then
 apply the substitution to the RHS before generating the instance.
 
+A wrinkle in all of this: when forming the type variable substitution for
+Generic1 instances, we map the last type variable of the tycon to Any. Why?
+It's because of wily data types like this one (#15012):
+
+   data T a = MkT (FakeOut a)
+   type FakeOut a = Int
+
+If we ignore a, then we'll produce the following Rep1 instance:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut a))
+     ...
+
+Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
+ensure that `a` is mapped to Any:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut Any))
+     ...
+
+And now all is good.
+
+Alternatively, we could have avoided this problem by expanding all type
+synonyms on the RHSes of Rep1 instances. But we might blow up the size of
+these types even further by doing this, so we choose not to do so.
+
 Note [Handling kinds in a Rep instance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Because Generic1 is poly-kinded, the representation types were generalized to
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
new file mode 100644
index 0000000000..1f6e06895d
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -0,0 +1,983 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- We don't want to spread the HasOccName
+                                      -- instance for Either
+module TcHoleErrors ( findValidHoleFits ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import TcRnMonad
+import TcMType
+import TcEvidence
+import TcType
+import Type
+import DataCon
+import Name
+import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )
+import PrelNames ( gHC_ERR )
+import Id
+import VarSet
+import VarEnv
+import Bag
+import ConLike          ( ConLike(..) )
+import Util
+import TcEnv (tcLookup)
+import Outputable
+import DynFlags
+import Maybes
+import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )
+
+import Control.Arrow ( (&&&) )
+
+import Control.Monad    ( filterM, replicateM )
+import Data.List        ( partition, sort, sortOn, nubBy )
+import Data.Graph       ( graphFromEdges, topSort )
+import Data.Function    ( on )
+
+
+import TcSimplify    ( simpl_top, runTcSDeriveds )
+import TcUnify       ( tcSubType_NC )
+
+import ExtractDocs ( extractDocs )
+import qualified Data.Map as Map
+import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )
+import HscTypes        ( ModIface(..) )
+import LoadIface       ( loadInterfaceForNameMaybe )
+
+{-
+Note [Valid hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+`findValidHoleFits` returns the "Valid hole fits include ..." message.
+For example, look at the following definitions in a file called test.hs:
+
+   import Data.List (inits)
+
+   f :: [String]
+   f = _ "hello, world"
+
+The hole in `f` would generate the message:
+
+  • Found hole: _ :: [Char] -> [String]
+  • In the expression: _
+    In the expression: _ "hello, world"
+    In an equation for ‘f’: f = _ "hello, world"
+  • Relevant bindings include f :: [String] (bound at test.hs:6:1)
+    Valid hole fits include
+      lines :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      words :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      inits :: forall a. [a] -> [[a]]
+        with inits @Char
+        (imported from ‘Data.List’ at mpt.hs:4:19-23
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      repeat :: forall a. a -> [a]
+        with repeat @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.List’))
+      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a
+        with fail @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+        with return @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a
+        with pure @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      read :: forall a. Read a => String -> a
+        with read @[String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘Text.Read’))
+      mempty :: forall a. Monoid a => a
+        with mempty @([Char] -> [String])
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+
+Valid hole fits are found by checking top level identifiers and local bindings
+in scope for whether their type can be instantiated to the the type of the hole.
+Additionally, we also need to check whether all relevant constraints are solved
+by choosing an identifier of that type as well, see Note [Relevant Constraints]
+
+Since checking for subsumption results in the side-effect of type variables
+being unified by the simplifier, we need to take care to restore them after
+to being flexible type variables after we've checked for subsumption.
+This is to avoid affecting the hole and later checks by prematurely having
+unified one of the free unification variables.
+
+When outputting, we sort the hole fits by the size of the types we'd need to
+apply by type application to the type of the fit to to make it fit. This is done
+in order to display "more relevant" suggestions first. Another option is to
+sort by building a subsumption graph of fits, i.e. a graph of which fits subsume
+what other fits, and then outputting those fits which are are subsumed by other
+fits (i.e. those more specific than other fits) first. This results in the ones
+"closest" to the type of the hole to be displayed first.
+
+To help users understand how the suggested fit works, we also display the values
+that the quantified type variables would take if that fit is used, like
+`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.
+If -XTypeApplications is enabled, this can even be copied verbatim as a
+replacement for the hole.
+
+
+Note [Nested implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For the simplifier to be able to use any givens present in the enclosing
+implications to solve relevant constraints, we nest the wanted subsumption
+constraints and relevant constraints within the enclosing implications.
+
+As an example, let's look at the following code:
+
+  f :: Show a => a -> String
+  f x = show _
+
+The hole will result in the hole constraint:
+
+  [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_))
+
+Here the nested implications are just one level deep, namely:
+
+  [Implic {
+      TcLevel = 2
+      Skolems = a_a1pa[sk:2]
+      No-eqs = True
+      Status = Unsolved
+      Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+      Wanted =
+        WC {wc_simple =
+              [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_))
+              [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))}
+      Binds = EvBindsVar<a1pi>
+      Needed inner = []
+      Needed outer = []
+      the type signature for:
+        f :: forall a. Show a => a -> String }]
+
+As we can see, the givens say that the information about the skolem
+`a_a1pa[sk:2]` fulfills the Show constraint.
+
+The simples are:
+
+  [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)]
+
+I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must
+fulfill `Show a0_a1pd[tau:2])`.
+
+So when we run the check, we need to make sure that the
+
+  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)
+
+Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits
+the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the
+meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted
+constraints needed by tcSubType_NC and the relevant constraints (see
+Note [Relevant Constraints] for more details) in the nested implications, we
+can pass the information in the givens along to the simplifier. For our example,
+we end up needing to check whether the following constraints are soluble.
+
+  WC {wc_impl =
+        Implic {
+          TcLevel = 2
+          Skolems = a_a1pa[sk:2]
+          No-eqs = True
+          Status = Unsolved
+          Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+          Wanted =
+            WC {wc_simple =
+                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}
+          Binds = EvBindsVar<a1pl>
+          Needed inner = []
+          Needed outer = []
+          the type signature for:
+            f :: forall a. Show a => a -> String }}
+
+But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested
+implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up
+with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.
+
+To avoid side-effects on the nested implications, we create a new EvBindsVar so
+that any changes to the ev binds during a check remains localised to that check.
+
+
+Note [Valid refinement hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the `-frefinement-level-hole-fits=N` flag is given, we additionally look
+for "valid refinement hole fits"", i.e. valid hole fits with up to N
+additional holes in them.
+
+With `-frefinement-level-hole-fits=0` (the default), GHC will find all
+identifiers 'f' (top-level or nested) that will fit in the hole.
+
+With `-frefinement-level-hole-fits=1`, GHC will additionally find all
+applications 'f _' that will fit in the hole, where 'f' is an in-scope
+identifier, applied to single argument.  It will also report the type of the
+needed argument (a new hole).
+
+And similarly as the number of arguments increases
+
+As an example, let's look at the following code:
+
+  f :: [Integer] -> Integer
+  f = _
+
+with `-frefinement-level-hole-fits=1`, we'd get:
+
+  Valid refinement hole fits include
+
+    foldl1 (_ :: Integer -> Integer -> Integer)
+      with foldl1 @[] @Integer
+      where foldl1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    foldr1 (_ :: Integer -> Integer -> Integer)
+      with foldr1 @[] @Integer
+      where foldr1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    const (_ :: Integer)
+      with const @Integer @[Integer]
+      where const :: forall a b. a -> b -> a
+    ($) (_ :: [Integer] -> Integer)
+      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer
+      where ($) :: forall a b. (a -> b) -> a -> b
+    fail (_ :: String)
+      with fail @((->) [Integer]) @Integer
+      where fail :: forall (m :: * -> *).
+                    Monad m =>
+                    forall a. String -> m a
+    return (_ :: Integer)
+      with return @((->) [Integer]) @Integer
+      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+    (Some refinement hole fits suppressed;
+      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)
+
+Which are hole fits with holes in them. This allows e.g. beginners to
+discover the fold functions and similar, but also allows for advanced users
+to figure out the valid functions in the Free monad, e.g.
+
+  instance Functor f => Monad (Free f) where
+      Pure a >>= f = f a
+      Free f >>= g = Free (fmap _a f)
+
+Will output (with -frefinment-level-hole-fits=1):
+    Found hole: _a :: Free f a -> Free f b
+          Where: ‘a’, ‘b’ are rigid type variables bound by
+                  the type signature for:
+                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
+                  at fms.hs:25:12-14
+                ‘f’ is a rigid type variable bound by
+    ...
+    Relevant bindings include
+      g :: a -> Free f b (bound at fms.hs:27:16)
+      f :: f (Free f a) (bound at fms.hs:27:10)
+      (>>=) :: Free f a -> (a -> Free f b) -> Free f b
+        (bound at fms.hs:25:12)
+    ...
+    Valid refinement hole fits include
+      ...
+      (=<<) (_ :: a -> Free f b)
+        with (=<<) @(Free f) @a @b
+        where (=<<) :: forall (m :: * -> *) a b.
+                      Monad m =>
+                      (a -> m b) -> m a -> m b
+        (imported from ‘Prelude’ at fms.hs:5:18-22
+        (and originally defined in ‘GHC.Base’))
+      ...
+
+Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).
+
+We find these refinement suggestions by considering hole fits that don't
+fit the type of the hole, but ones that would fit if given an additional
+argument. We do this by creating a new type variable with `newOpenFlexiTyVar`
+(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type
+`t_a1/m[tau:1] -> v` where `v` is the type of the hole.
+
+Since the simplifier is free to unify this new type variable with any type, we
+can discover any identifiers that would fit if given another identifier of a
+suitable type. This is then generalized so that we can consider any number of
+additional arguments by setting the `-frefinement-level-hole-fits` flag to any
+number, and then considering hole fits like e.g. `foldl _ _` with two additional
+arguments.
+
+To make sure that the refinement hole fits are useful, we check that the types
+of the additional holes have a concrete value and not just an invented type
+variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,
+and limits the number of less than useful refinement hole fits.
+
+Additionally, to further aid the user in their implementation, we show the
+types of the holes the binding would have to be applied to in order to work.
+In the free monad example above, this is demonstrated with
+`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to
+be applied to an expression of type `a -> Free f b` in order to match.
+If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.
+
+
+Note [Relevant Constraints]
+~~~~~~~~~~~~~~~~~~~
+
+As highlighted by Trac #14273, we need to check any relevant constraints as well
+as checking for subsumption. Relevant constraints are the simple constraints
+whose free unification variables are mentioned in the type of the hole.
+
+In the simplest case, these are all non-hole constraints in the simples, such
+as is the case in
+
+  f :: String
+  f = show _
+
+Where the simples will be :
+
+  [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)]
+
+However, when there are multiple holes, we need to be more careful. As an
+example, Let's take a look at the following code:
+
+  f :: Show a => a -> String
+  f x = show (_b (show _a))
+
+Here there are two holes, `_a` and `_b`, and the simple constraints passed to
+findValidHoleFits are:
+
+  [[WD] _a_a1pi {0}:: String
+                        -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)),
+    [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),
+    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]
+
+
+Here we have the two hole constraints for `_a` and `_b`, but also additional
+constraints that these holes must fulfill. When we are looking for a match for
+the hole `_a`, we filter the simple constraints to the "Relevant constraints",
+by throwing out all hole constraints and any constraints which do not mention
+a variable mentioned in the type of the hole. For hole `_a`, we will then
+only require that the `$dShow_a1pp` constraint is solved, since that is
+the only non-hole constraint that mentions any free type variables mentioned in
+the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the
+hole `_b` we only require that the `$dShow_a1pe` constraint is solved.
+
+Note [Leaking errors]
+~~~~~~~~~~~~~~~~~~~
+
+When considering candidates, GHC believes that we're checking for validity in
+actual source. However, As evidenced by #15321, #15007 and #15202, this can
+cause bewildering error messages. The solution here is simple: if a candidate
+would cause the type checker to error, it is not a valid hole fit, and thus it
+is discarded.
+
+-}
+
+
+
+
+data HoleFitDispConfig = HFDC { showWrap :: Bool
+                              , showWrapVars :: Bool
+                              , showType :: Bool
+                              , showProv :: Bool
+                              , showMatches :: Bool }
+
+debugHoleFitDispConfig :: HoleFitDispConfig
+debugHoleFitDispConfig = HFDC True True True False False
+
+
+-- We read the various -no-show-*-of-hole-fits flags
+-- and set the display config accordingly.
+getHoleFitDispConfig :: TcM HoleFitDispConfig
+getHoleFitDispConfig
+  = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits
+       ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits
+       ; sType <- goptM Opt_ShowTypeOfHoleFits
+       ; sProv <- goptM Opt_ShowProvOfHoleFits
+       ; sMatc <- goptM Opt_ShowMatchesOfHoleFits
+       ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars
+                    , showProv = sProv, showType = sType
+                    , showMatches = sMatc } }
+
+-- Which sorting algorithm to use
+data SortingAlg = NoSorting      -- Do not sort the fits at all
+                | BySize         -- Sort them by the size of the match
+                | BySubsumption  -- Sort by full subsumption
+                deriving (Eq, Ord)
+
+getSortingAlg :: TcM SortingAlg
+getSortingAlg =
+    do { shouldSort <- goptM Opt_SortValidHoleFits
+       ; subsumSort <- goptM Opt_SortBySubsumHoleFits
+       ; sizeSort <- goptM Opt_SortBySizeHoleFits
+       -- We default to sizeSort unless it has been explicitly turned off
+       -- or subsumption sorting has been turned on.
+       ; return $ if not shouldSort
+                    then NoSorting
+                    else if subsumSort
+                         then BySubsumption
+                         else if sizeSort
+                              then BySize
+                              else NoSorting }
+
+-- HoleFit is the type we use for valid hole fits. It contains the
+-- element that was checked, the Id of that element as found by `tcLookup`,
+-- and the refinement level of the fit, which is the number of extra argument
+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
+data HoleFit = HoleFit { hfElem :: Maybe GlobalRdrElt -- The element that was
+                                                      -- if a global, nothing
+                                                      -- if it is a local.
+                       , hfId :: Id       -- The elements id in the TcM
+                       , hfType :: TcType -- The type of the id, possibly zonked
+                       , hfRefLvl :: Int  -- The number of holes in this fit
+                       , hfWrap :: [TcType] -- The wrapper for the match
+                       , hfMatches :: [TcType]  -- What the refinement
+                                                -- variables got matched with,
+                                                -- if anything
+                       , hfDoc :: Maybe HsDocString } -- Documentation of this
+                                                      -- HoleFit, if available.
+
+hfName :: HoleFit -> Name
+hfName = idName . hfId
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf = case hfElem hf of
+               Just gre -> gre_lcl gre
+               Nothing -> True
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+   (==) = (==) `on` hfId
+
+-- We compare HoleFits by their gre_name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+  compare a b = cmp a b
+    where cmp  = if hfRefLvl a == hfRefLvl b
+                 then compare `on` hfName
+                 else compare `on` hfRefLvl
+
+instance Outputable HoleFit where
+    ppr = pprHoleFit debugHoleFitDispConfig
+
+instance (HasOccName a, HasOccName b) => HasOccName (Either a b) where
+    occName = either occName occName
+
+instance HasOccName GlobalRdrElt where
+    occName = occName . gre_name
+
+-- If enabled, we go through the fits and add any associated documentation,
+--  by looking it up in the module or the environment (for local fits)
+addDocs :: [HoleFit] -> TcM [HoleFit]
+addDocs fits =
+  do { showDocs <- goptM Opt_ShowDocsOfHoleFits
+     ; if showDocs
+       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv
+               ; mapM (upd lclDocs) fits }
+       else return fits }
+  where
+   msg = text "TcHoleErrors addDocs"
+   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
+     = Map.lookup name dmap
+   upd lclDocs fit =
+     let name = hfName fit in
+     do { doc <- if hfIsLcl fit
+                 then pure (Map.lookup name lclDocs)
+                 else do { mbIface <- loadInterfaceForNameMaybe msg name
+                         ; return $ mbIface >>= lookupInIface name }
+        ; return $ fit {hfDoc = doc} }
+
+-- For pretty printing hole fits, we display the name and type of the fit,
+-- with added '_' to represent any extra arguments in case of a non-zero
+-- refinement level.
+pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
+    where name = case hfElem hf of
+                      Just gre -> gre_name gre
+                      Nothing -> hfName hf
+          ty = hfType hf
+          matches =  hfMatches hf
+          wrap = hfWrap hf
+          tyApp = sep $ map ((text "@" <>) . pprParendType) wrap
+          tyAppVars = sep $ punctuate comma $
+              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $
+                zip vars wrap
+            where
+              vars = unwrapTypeVars ty
+              -- Attempts to get all the quantified type variables in a type,
+              -- e.g.
+              -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a
+              -- into [m, a]
+              unwrapTypeVars :: Type -> [TyVar]
+              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
+                                  Just (_, unfunned) -> unwrapTypeVars unfunned
+                                  _ -> []
+                where (vars, unforalled) = splitForAllTys t
+          holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches
+          holeDisp = if sMs then holeVs
+                     else sep $ replicate (length matches) $ text "_"
+          occDisp = pprPrefixOcc name
+          tyDisp = ppWhen sTy $ dcolon <+> ppr ty
+          has = not . null
+          wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))
+                      $ text "with" <+> if sWrp || not sTy
+                                        then occDisp <+> tyApp
+                                        else tyAppVars
+          docs = case hfDoc hf of
+                   Just d ->
+                     text "{-^" <>
+                     (vcat . map text . lines . unpackHDS) d
+                     <> text "-}"
+                   _ -> empty
+          funcInfo = ppWhen (has matches && sTy) $
+                       text "where" <+> occDisp <+> tyDisp
+          subDisp = occDisp <+> if has matches then holeDisp else tyDisp
+          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
+          provenance = ppWhen sProv $ parens $
+                case hfElem hf of
+                    Just gre -> pprNameProvenance gre
+                    Nothing -> text "bound at" <+> ppr (getSrcLoc name)
+
+getLocalBindings :: TidyEnv -> Ct -> TcM [Id]
+getLocalBindings tidy_orig ct
+ = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc)
+      ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) }
+  where
+    loc     = ctEvLoc (ctEvidence ct)
+    lcl_env = ctLocEnv loc
+
+    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
+    go _ sofar [] = return (reverse sofar)
+    go env sofar (tc_bndr : tc_bndrs) =
+        case tc_bndr of
+          TcIdBndr id _ -> keep_it id
+          _ -> discard_it
+     where
+        discard_it = go env sofar tc_bndrs
+        keep_it id = go env (id:sofar) tc_bndrs
+
+-- See Note [Valid hole fits include ...]
+findValidHoleFits :: TidyEnv        --The tidy_env for zonking
+                  -> [Implication]  --Enclosing implications for givens
+                  -> [Ct] -- The  unsolved simple constraints in the
+                          -- implication for the hole.
+                  -> Ct   -- The hole constraint itself
+                  -> TcM (TidyEnv, SDoc)
+findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
+  do { rdr_env <- getGlobalRdrEnv
+     ; lclBinds <- getLocalBindings tidy_env ct
+     ; maxVSubs <- maxValidHoleFits <$> getDynFlags
+     ; hfdc <- getHoleFitDispConfig
+     ; sortingAlg <- getSortingAlg
+     ; refLevel <- refLevelHoleFits <$> getDynFlags
+     ; traceTc "findingValidHoleFitsFor { " $ ppr ct
+     ; traceTc "hole_lvl is:" $ ppr hole_lvl
+     ; traceTc "implics are: " $ ppr implics
+     ; traceTc "simples are: " $ ppr simples
+     ; traceTc "locals are: " $ ppr lclBinds
+     ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
+           -- We remove binding shadowings here, but only for the local level.
+           -- this is so we e.g. suggest the global fmap from the Functor class
+           -- even though there is a local definition as well, such as in the
+           -- Free monad example.
+           locals = removeBindingShadowing $ map Left lclBinds ++ map Right lcl
+           globals = map Right gbl
+           to_check = locals ++ globals
+     ; (searchDiscards, subs) <-
+        findSubs sortingAlg maxVSubs to_check (hole_ty, [])
+     ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs
+     ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
+     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs
+           vDiscards = pVDisc || searchDiscards
+     ; subs_with_docs <- addDocs limited_subs
+     ; let vMsg = ppUnless (null subs_with_docs) $
+                    hang (text "Valid hole fits include") 2 $
+                      vcat (map (pprHoleFit hfdc) subs_with_docs)
+                        $$ ppWhen vDiscards subsDiscardMsg
+     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
+     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then
+         do { maxRSubs <- maxRefHoleFits <$> getDynFlags
+            -- We can use from just, since we know that Nothing >= _ is False.
+            ; let refLvls = [1..(fromJust refLevel)]
+            -- We make a new refinement type for each level of refinement, where
+            -- the level of refinement indicates number of additional arguments
+            -- to allow.
+            ; ref_tys <- mapM mkRefTy refLvls
+            ; traceTc "ref_tys are" $ ppr ref_tys
+            ; refDs <- mapM (findSubs sortingAlg maxRSubs to_check) ref_tys
+            ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs
+            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs
+            -- For refinement substitutions we want matches
+            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),
+            -- and others in that vein to appear last, since these are
+            -- unlikely to be the most relevant fits.
+            ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty
+            ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap
+                  (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs
+                  (pRDisc, exact_last_rfits) =
+                    possiblyDiscard maxRSubs $ not_exact ++ exact
+                  rDiscards = pRDisc || any fst refDs
+            ; rsubs_with_docs <- addDocs exact_last_rfits
+            ; return (tidy_env,
+                ppUnless (null rsubs_with_docs) $
+                  hang (text "Valid refinement hole fits include") 2 $
+                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)
+                    $$ ppWhen rDiscards refSubsDiscardMsg) }
+       else return (tidy_env, empty)
+     ; traceTc "findingValidHoleFitsFor }" empty
+     ; return (tidy_env, vMsg $$ refMsg) }
+  where
+    -- We extract the type, the tcLevel and the types free variables
+    -- from from the constraint.
+    hole_ty :: TcPredType
+    hole_ty = ctPred ct
+    hole_fvs = tyCoFVsOfType hole_ty
+    hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct
+
+    -- We make a refinement type by adding a new type variable in front
+    -- of the type of t h hole, going from e.g. [Integer] -> Integer
+    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier
+    -- to unify the new type variable with any type, allowing us
+    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead
+    -- of only concrete hole fits like `sum`.
+    mkRefTy :: Int -> TcM (TcType, [TcTyVar])
+    mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars
+      where newTyVars = replicateM refLvl $ setLvl <$>
+                            (newOpenTypeKind >>= newFlexiTyVar)
+            setLvl = flip setMetaTyVarTcLevel hole_lvl
+            wrapWithVars vars = mkFunTys (map mkTyVarTy vars) hole_ty
+
+    sortFits :: SortingAlg    -- How we should sort the hole fits
+             -> [HoleFit]     -- The subs to sort
+             -> TcM [HoleFit]
+    sortFits NoSorting subs = return subs
+    sortFits BySize subs
+        = (++) <$> sortBySize (sort lclFits)
+               <*> sortBySize (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+    -- To sort by subsumption, we invoke the sortByGraph function, which
+    -- builds the subsumption graph for the fits and then sorts them using a
+    -- graph sort.  Since we want locals to come first anyway, we can sort
+    -- them separately. The substitutions are already checked in local then
+    -- global order, so we can get away with using span here.
+    -- We use (<*>) to expose the parallelism, in case it becomes useful later.
+    sortFits BySubsumption subs
+        = (++) <$> sortByGraph (sort lclFits)
+               <*> sortByGraph (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+
+    -- See Note [Relevant Constraints]
+    relevantCts :: [Ct]
+    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []
+                  else filter isRelevant simples
+      where ctFreeVarSet :: Ct -> VarSet
+            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred
+            hole_fv_set = fvVarSet hole_fvs
+            anyFVMentioned :: Ct -> Bool
+            anyFVMentioned ct = not $ isEmptyVarSet $
+                                  ctFreeVarSet ct `intersectVarSet` hole_fv_set
+            -- We filter out those constraints that have no variables (since
+            -- they won't be solved by finding a type for the type variable
+            -- representing the hole) and also other holes, since we're not
+            -- trying to find hole fits for many holes at once.
+            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))
+                            && anyFVMentioned ct
+                            && not (isHoleCt ct)
+
+    unfoldWrapper :: HsWrapper -> [Type]
+    unfoldWrapper = reverse . unfWrp'
+      where unfWrp' (WpTyApp ty) = [ty]
+            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
+            unfWrp' _ = []
+
+
+    -- We only clone flexi type variables, and we need to be able to check
+    -- whether a variable is filled or not.
+    isFlexiTyVar :: TcTyVar -> TcM Bool
+    isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
+    isFlexiTyVar _ = return False
+
+    -- Takes a list of free variables and restores any Flexi type variables
+    -- in free_vars after the action is run.
+    withoutUnification :: FV -> TcM a -> TcM a
+    withoutUnification free_vars action
+      = do { flexis <- filterM isFlexiTyVar fuvs
+            ; result <- action
+              -- Reset any mutated free variables
+            ; mapM_ restore flexis
+            ; return result }
+      where restore = flip writeTcRef Flexi . metaTyVarRef
+            fuvs = fvVarList free_vars
+
+    -- The real work happens here, where we invoke the type checker using
+    -- tcCheckHoleFit to see whether the given type fits the hole.
+    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the
+                                    -- refinement variables created to simulate
+                                    -- additional holes (if any), and the list
+                                    -- of those variables (possibly empty).
+                                    -- As an example: If the actual type of the
+                                    -- hole (as specified by the hole
+                                    -- constraint CHoleExpr passed to
+                                    -- findValidHoleFits) is t and we want to
+                                    -- simulate N additional holes, h_ty will
+                                    -- be  r_1 -> ... -> r_N -> t, and
+                                    -- ref_vars will be [r_1, ... , r_N].
+                                    -- In the base case with no additional
+                                    -- holes, h_ty will just be t and ref_vars
+                                    -- will be [].
+             -> TcType -- The type we're checking to whether it can be
+                       -- instantiated to the type h_ty.
+             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we
+                                                 -- return Nothing. Otherwise,
+                                                 -- we Just return the list of
+                                                 -- types that quantified type
+                                                 -- variables in ty would take
+                                                 -- if used in place of h_ty,
+                                                 -- and the list types of any
+                                                 -- additional holes simulated
+                                                 -- with the refinement
+                                                 -- variables in ref_vars.
+    fitsHole (h_ty, ref_vars) ty =
+    -- We wrap this with the withoutUnification to avoid having side-effects
+    -- beyond the check, but we rely on the side-effects when looking for
+    -- refinement hole fits, so we can't wrap the side-effects deeper than this.
+      withoutUnification fvs $
+      do { traceTc "checkingFitOf {" $ ppr ty
+         ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty
+         ; traceTc "Did it fit?" $ ppr fits
+         ; traceTc "wrap is: " $ ppr wrp
+         ; traceTc "checkingFitOf }" empty
+         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)
+         -- We'd like to avoid refinement suggestions like `id _ _` or
+         -- `head _ _`, and only suggest refinements where our all phantom
+         -- variables got unified during the checking. This can be disabled
+         -- with the `-fabstract-refinement-hole-fits` flag.
+         -- Here we do the additional handling when there are refinement
+         -- variables, i.e. zonk them to read their final value to check for
+         -- abstract refinements, and to report what the type of the simulated
+         -- holes must be for this to be a match.
+         ; if fits
+           then if null ref_vars
+                then return (Just (z_wrp_tys, []))
+                else do { let -- To be concrete matches, matches have to
+                              -- be more than just an invented type variable.
+                              fvSet = fvVarSet fvs
+                              notAbstract :: TcType -> Bool
+                              notAbstract t = case getTyVar_maybe t of
+                                                Just tv -> tv `elemVarSet` fvSet
+                                                _ -> True
+                              allConcrete = all notAbstract z_wrp_tys
+                        ; z_vars  <- zonkTcTyVars ref_vars
+                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars
+                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs
+                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits
+                        ; if allowAbstract || (allFilled && allConcrete )
+                          then return $ Just (z_wrp_tys, z_vars)
+                          else return Nothing }
+           else return Nothing }
+     where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
+
+    -- We zonk the hole fits so that the output aligns with the rest
+    -- of the typed hole error message output.
+    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
+    zonkSubs = zonkSubs' []
+      where zonkSubs' zs env [] = return (env, reverse zs)
+            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf
+                                           ; zonkSubs' (z:zs) env' hfs }
+            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}
+              = do { (env, ty') <- zonkTidyTcType env ty
+                   ; (env, m') <- zonkTidyTcTypes env m
+                   ; (env, wrp') <- zonkTidyTcTypes env wrp
+                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}
+                   ; return (env, zFit ) }
+
+    -- Based on the flags, we might possibly discard some or all the
+    -- fits we've found.
+    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
+    possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)
+    possiblyDiscard Nothing fits = (False, fits)
+
+
+    -- Sort by size uses as a measure for relevance the sizes of the
+    -- different types needed to instantiate the fit to the type of the hole.
+    -- This is much quicker than sorting by subsumption, and gives reasonable
+    -- results in most cases.
+    sortBySize :: [HoleFit] -> TcM [HoleFit]
+    sortBySize = return . sortOn sizeOfFit
+      where sizeOfFit :: HoleFit -> TypeSize
+            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap
+
+    -- Based on a suggestion by phadej on #ghc, we can sort the found fits
+    -- by constructing a subsumption graph, and then do a topological sort of
+    -- the graph. This makes the most specific types appear first, which are
+    -- probably those most relevant. This takes a lot of work (but results in
+    -- much more useful output), and can be disabled by
+    -- '-fno-sort-valid-hole-fits'.
+    sortByGraph :: [HoleFit] -> TcM [HoleFit]
+    sortByGraph fits = go [] fits
+      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
+            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)
+              where fvs = tyCoFVsOfTypes [ht,ty]
+            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
+            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar
+                             ; return $ uncurry (++)
+                                         $ partition hfIsLcl topSorted }
+              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)
+                    (graph, fromV, _) = graphFromEdges $ map toV sofar
+                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph
+            go sofar (hf:hfs) =
+              do { adjs <-
+                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits
+                 ; go ((hf, adjs):sofar) hfs }
+
+    findSubs :: SortingAlg         -- Whether we should sort the subs or not
+             -> Maybe Int          -- How many we should output, if limited
+             -> [Either Id GlobalRdrElt] -- The elements to check whether fit
+             -> (TcType, [TcTyVar]) -- The type to check for fits and refinement
+                                    -- variables for emulating additional holes
+             -> TcM (Bool, [HoleFit]) -- We return whether or not we stopped due
+                                      -- to running out of gas and the fits we
+                                      -- found.
+    -- We don't check if no output is desired.
+    findSubs _ (Just 0) _ _ = return (False, [])
+    findSubs sortAlg maxSubs to_check ht@(hole_ty, _) =
+      do { traceTc "checkingFitsFor {" $ ppr hole_ty
+         -- If we're not going to sort anyway, we can stop going after
+         -- having found `maxSubs` hole fits.
+         ; let limit = if sortAlg > NoSorting then Nothing else maxSubs
+         ; (discards, subs) <- go [] emptyVarSet limit ht to_check
+         ; traceTc "checkingFitsFor }" empty
+         ; return (discards, subs) }
+      where
+        -- Kickoff the checking of the elements.
+        -- We iterate over the elements, checking each one in turn for whether
+        -- it fits, and adding it to the results if it does.
+        go :: [HoleFit]            -- What we've found so far.
+            -> VarSet              -- Ids we've already checked
+            -> Maybe Int           -- How many we're allowed to find, if limited
+            -> (TcType, [TcTyVar]) -- The type, and its refinement variables.
+            -> [Either Id GlobalRdrElt] -- The elements we've yet to check.
+            -> TcM (Bool, [HoleFit])
+        go subs _ _ _ [] = return (False, reverse subs)
+        go subs _ (Just 0) _ _ = return (True, reverse subs)
+        go subs seen maxleft ty (el:elts) =
+          -- See Note [Leaking errors]
+          tryTcDiscardingErrs discard_it $
+          do { traceTc "lookingUp" $ ppr el
+             ; maybeThing <- lookup el
+             ; case maybeThing of
+                 Just id | not_trivial id ->
+                           do { fits <- fitsHole ty (idType id)
+                              ; case fits of
+                                  Just (wrp, matches) -> keep_it id wrp matches
+                                  _ -> discard_it }
+                 _ -> discard_it }
+          where discard_it = go subs seen maxleft ty elts
+                keep_it id wrp ms = go (fit:subs) (extendVarSet seen id)
+                                  ((\n -> n - 1) <$> maxleft) ty elts
+                  where fit = HoleFit { hfElem = mbel, hfId = id
+                                      , hfType = idType id
+                                      , hfRefLvl = length (snd ty)
+                                      , hfWrap = wrp, hfMatches = ms
+                                      , hfDoc = Nothing }
+                        mbel = either (const Nothing) Just el
+                -- We want to filter out undefined and the likes from GHC.Err
+                not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
+                lookup :: Either Id GlobalRdrElt -> TcM (Maybe Id)
+                lookup (Left id) = return $ Just id
+                lookup (Right el) =
+                  do { thing <- tcLookup (gre_name el)
+                     ; case thing of
+                         ATcId {tct_id = id} -> return $ Just id
+                         AGlobal (AnId id)   -> return $ Just id
+                         AGlobal (AConLike (RealDataCon con))  ->
+                           return $ Just (dataConWrapId con)
+                         _ -> return Nothing }
+
+
+-- We don't (as of yet) handle holes in types, only in expressions.
+findValidHoleFits env _ _ _ = return (env, empty)
+
+subsDiscardMsg :: SDoc
+subsDiscardMsg =
+    text "(Some hole fits suppressed;" <+>
+    text "use -fmax-valid-hole-fits=N" <+>
+    text "or -fno-max-valid-hole-fits)"
+
+refSubsDiscardMsg :: SDoc
+refSubsDiscardMsg =
+    text "(Some refinement hole fits suppressed;" <+>
+    text "use -fmax-refinement-hole-fits=N" <+>
+    text "or -fno-max-refinement-hole-fits)"
+
+
+-- | Reports whether first type (ty_a) subsumes the second type (ty_b),
+-- discarding any errors. Subsumption here means that the ty_b can fit into the
+-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b
+
+
+-- | A tcSubsumes which takes into account relevant constraints, to fix trac
+-- #14273. This makes sure that when checking whether a type fits the hole,
+-- the type has to be subsumed by type of the hole as well as fulfill all
+-- constraints on the type of the hole.
+-- Note: The simplifier may perform unification, so make sure to restore any
+-- free type variables to avoid side-effects.
+tcCheckHoleFit :: Cts                   -- Any relevant Cts to the hole.
+               -> [Implication]         -- The nested implications of the hole
+                                        -- with the innermost implication first
+               -> TcSigmaType           -- The type of the hole.
+               -> TcSigmaType           -- The type to check whether fits.
+               -> TcM (Bool, HsWrapper)
+tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty
+    = return (True, idHsWrapper)
+tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
+  do { -- We wrap the subtype constraint in the implications to pass along the
+       -- givens, and so we must ensure that any nested implications and skolems
+       -- end up with the correct level. The implications are ordered so that
+       -- the innermost (the one with the highest level) is first, so it
+       -- suffices to get the level of the first one (or the current level, if
+       -- there are no implications involved).
+       innermost_lvl <- case implics of
+                          [] -> getTcLevel
+                          -- imp is the innermost implication
+                          (imp:_) -> return (ic_tclvl imp)
+     ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $
+                          tcSubType_NC ExprSigCtxt ty hole_ty
+     ; traceTc "Checking hole fit {" empty
+     ; traceTc "wanteds are: " $ ppr wanted
+     ; if isEmptyWC wanted && isEmptyBag relevantCts
+       then traceTc "}" empty >> return (True, wrp)
+       else do { fresh_binds <- newTcEvBinds
+                -- The relevant constraints may contain HoleDests, so we must
+                -- take care to clone them as well (to avoid #15370).
+               ; cloned_relevants <- mapBagM cloneWanted relevantCts
+                 -- We wrap the WC in the nested implications, see
+                 -- Note [Nested Implications]
+               ; let outermost_first = reverse implics
+                     setWC = setWCAndBinds fresh_binds
+                    -- We add the cloned relevants to the wanteds generated by
+                    -- the call to tcSubType_NC, see Note [Relevant Constraints]
+                    -- There's no need to clone the wanteds, because they are
+                    -- freshly generated by `tcSubtype_NC`.
+                     w_rel_cts = addSimples wanted cloned_relevants
+                     w_givens = foldr setWC w_rel_cts outermost_first
+               ; traceTc "w_givens are: " $ ppr w_givens
+               ; rem <- runTcSDeriveds $ simpl_top w_givens
+               -- We don't want any insoluble or simple constraints left, but
+               -- solved implications are ok (and neccessary for e.g. undefined)
+               ; traceTc "rems was:" $ ppr rem
+               ; traceTc "}" empty
+               ; return (isSolvedWC rem, wrp) } }
+     where
+       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.
+                     -> Implication        -- The implication to put WC in.
+                     -> WantedConstraints  -- The WC constraints to put implic.
+                     -> WantedConstraints  -- The new constraints.
+       setWCAndBinds binds imp wc
+         = WC { wc_simple = emptyBag
+              , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot
new file mode 100644
index 0000000000..16e0c953c0
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs-boot
@@ -0,0 +1,12 @@
+-- This boot file is in place to break the loop where:
+-- + TcSimplify calls 'TcErrors.reportUnsolved',
+-- + which calls 'TcHoleErrors.findValidHoleFits`
+-- + which calls 'TcSimplify.simpl_top'
+module TcHoleErrors where
+
+import TcRnTypes  ( TcM, Ct, Implication )
+import Outputable ( SDoc )
+import VarEnv     ( TidyEnv )
+
+findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
+                  -> TcM (TidyEnv, SDoc)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 413751c440..3363aa2be0 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -10,7 +10,8 @@ checker.
 -}
 
 {-# LANGUAGE CPP, TupleSections #-}
-{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcHsSyn (
         -- * Extracting types from HsSyn
@@ -29,27 +30,36 @@ module TcHsSyn (
         -- | For a description of "zonking", see Note [What is zonking?]
         -- in TcMType
         zonkTopDecls, zonkTopExpr, zonkTopLExpr,
-        zonkTopBndrs, zonkTyBndrsX,
-        zonkTyVarBindersX, zonkTyVarBinderX,
-        emptyZonkEnv, mkEmptyZonkEnv,
-        zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
-        zonkCoToCo, zonkSigType,
-        zonkEvBinds,
+        zonkTopBndrs,
+        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
+        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
+        zonkTyBndrs, zonkTyBndrsX,
+        zonkTcTypeToType,  zonkTcTypeToTypeX,
+        zonkTcTypesToTypes, zonkTcTypesToTypesX,
+        zonkTyVarOcc,
+        zonkCoToCo,
+        zonkEvBinds, zonkTcEvBinds,
+        zonkTcMethInfoToMethInfoX
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import Id
 import IdInfo
 import TcRnMonad
 import PrelNames
+import BuildTyCl ( TcMethInfo, MethInfo )
 import TcType
 import TcMType
+import TcEnv   ( tcLookupGlobalOnly )
 import TcEvidence
 import TysPrim
-import TyCon   ( isUnboxedTupleTyCon )
+import TyCon
 import TysWiredIn
+import TyCoRep( CoercionHole(..) )
 import Type
 import Coercion
 import ConLike
@@ -68,6 +78,7 @@ import Bag
 import Outputable
 import Util
 import UniqFM
+import CoreSyn
 
 import Control.Monad
 import Data.List  ( partition )
@@ -86,28 +97,27 @@ hsLPatType :: OutPat GhcTc -> Type
 hsLPatType (L _ pat) = hsPatType pat
 
 hsPatType :: Pat GhcTc -> Type
-hsPatType (ParPat pat)                = hsLPatType pat
-hsPatType (WildPat ty)                = ty
-hsPatType (VarPat (L _ var))          = idType var
-hsPatType (BangPat pat)               = hsLPatType pat
-hsPatType (LazyPat pat)               = hsLPatType pat
-hsPatType (LitPat lit)                = hsLitType lit
-hsPatType (AsPat var _)               = idType (unLoc var)
-hsPatType (ViewPat _ _ ty)            = ty
-hsPatType (ListPat _ ty Nothing)      = mkListTy ty
-hsPatType (ListPat _ _ (Just (ty,_))) = ty
-hsPatType (PArrPat _ ty)              = mkPArrTy ty
-hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
-hsPatType (SumPat _ _ _ tys)          = mkSumTy tys
+hsPatType (ParPat _ pat)                = hsLPatType pat
+hsPatType (WildPat ty)                  = ty
+hsPatType (VarPat _ (L _ var))          = idType var
+hsPatType (BangPat _ pat)               = hsLPatType pat
+hsPatType (LazyPat _ pat)               = hsLPatType pat
+hsPatType (LitPat _ lit)                = hsLitType lit
+hsPatType (AsPat _ var _)               = idType (unLoc var)
+hsPatType (ViewPat ty _ _)              = ty
+hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
 hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
-                                      = conLikeResTy con tys
-hsPatType (SigPatOut _ ty)            = ty
-hsPatType (NPat _ _ _ ty)             = ty
-hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
-hsPatType (CoPat _ _ ty)              = ty
-hsPatType p                           = pprPanic "hsPatType" (ppr p)
-
-hsLitType :: HsLit p -> TcType
+                                        = conLikeResTy con tys
+hsPatType (SigPat ty _)                 = ty
+hsPatType (NPat ty _ _ _)               = ty
+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
+hsPatType (CoPat _ _ _ ty)              = ty
+hsPatType p                             = pprPanic "hsPatType" (ppr p)
+
+hsLitType :: HsLit (GhcPass p) -> TcType
 hsLitType (HsChar _ _)       = charTy
 hsLitType (HsCharPrim _ _)   = charPrimTy
 hsLitType (HsString _ _)     = stringTy
@@ -121,14 +131,15 @@ hsLitType (HsInteger _ _ ty) = ty
 hsLitType (HsRat _ _ ty)     = ty
 hsLitType (HsFloatPrim _ _)  = floatPrimTy
 hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
 
 -- Overloaded literals. Here mainly because it uses isIntTy etc
 
 shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
 shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
-  | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt def int))
+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))
   | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
-  | isIntegerTy ty = Just (HsLit (HsInteger src i ty))
+  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
   | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
         -- The 'otherwise' case is important
         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
@@ -137,16 +148,16 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
         -- literals, compiled without -O
 
 shortCutLit _ (HsFractional f) ty
-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim def f))
-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim def f))
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
   | otherwise     = Nothing
 
 shortCutLit _ (HsIsString src s) ty
-  | isStringTy ty = Just (HsLit (HsString src s))
+  | isStringTy ty = Just (HsLit noExt (HsString src s))
   | otherwise     = Nothing
 
 mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
-mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit)
+mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
 
 ------------------------------
 hsOverLitName :: OverLitVal -> Name
@@ -181,59 +192,111 @@ the environment manipulation is tiresome.
 -}
 
 -- Confused by zonking? See Note [What is zonking?] in TcMType.
-type UnboundTyVarZonker = TcTyVar -> TcM Type
-        -- How to zonk an unbound type variable
-        -- The TcTyVar is
-        --     (a) a MetaTv
-        --     (b) Flexi and
-        --     (c) its kind is already zonked
-        -- Note [Zonking the LHS of a RULE]
-
--- | A ZonkEnv carries around several bits.
--- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as
--- defined in zonkTypeZapping), except on the LHS of rules. See
--- Note [Zonking the LHS of a RULE].
---
--- The (TyCoVarEnv TyVar) and is just an optimisation: when binding a
--- tyvar or covar, we zonk the kind right away and add a mapping to
--- the env. This prevents re-zonking the kind at every occurrence. But
--- this is *just* an optimisation.
---
--- The final (IdEnv Var) optimises zonking for Ids. It is
--- knot-tied. We must be careful never to put coercion variables
--- (which are Ids, after all) in the knot-tied env, because coercions
--- can appear in types, and we sometimes inspect a zonked type in this
--- module.
---
+
+-- | See Note [The ZonkEnv]
 -- Confused by zonking? See Note [What is zonking?] in TcMType.
-data ZonkEnv
-  = ZonkEnv
-      UnboundTyVarZonker
-      (TyCoVarEnv TyVar)
-      (IdEnv      Var)         -- What variables are in scope
-        -- Maps an Id or EvVar to its zonked version; both have the same Name
-        -- Note that all evidence (coercion variables as well as dictionaries)
-        --      are kept in the ZonkEnv
-        -- Only *type* abstraction is done by side effect
-        -- Is only consulted lazily; hence knot-tying
+data ZonkEnv  -- See Note [The ZonkEnv]
+  = ZonkEnv { ze_flexi  :: ZonkFlexi
+            , ze_tv_env :: TyCoVarEnv TyCoVar
+            , ze_id_env :: IdEnv      Id
+            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
+{- Note [The ZonkEnv]
+~~~~~~~~~~~~~~~~~~~~~
+* ze_flexi :: ZonkFlexi says what to do with a
+  unification variable that is still un-unified.
+  See Note [Un-unified unification variables]
+
+* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
+  of a tyvar or covar, we zonk the kind right away and add a mapping
+  to the env. This prevents re-zonking the kind at every
+  occurrence. But this is *just* an optimisation.
+
+* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
+  occurrences of the Id point to a single zonked copy, built at the
+  binding site.
+
+  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
+  In a mutually recusive group
+     rec { f = ...g...; g = ...f... }
+  we want the occurrence of g to point to the one zonked Id for g,
+  and the same for f.
+
+  Because it is knot-tied, we must be careful to consult it lazily.
+  Specifically, zonkIdOcc is not monadic.
+
+* ze_meta_tv_env: see Note [Sharing when zonking to Type]
+
+
+Notes:
+  * We must be careful never to put coercion variables (which are Ids,
+    after all) in the knot-tied ze_id_env, because coercions can
+    appear in types, and we sometimes inspect a zonked type in this
+    module.  [Question: where, precisely?]
+
+  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
+    a second reason that ze_tv_env can't be monadic.
+
+  * An obvious suggestion would be to have one VarEnv Var to
+    replace both ze_id_env and ze_tv_env, but that doesn't work
+    because of the knot-tying stuff mentioned above.
+
+Note [Un-unified unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do if we find a Flexi unification variable?
+There are three possibilities:
+
+* DefaultFlexi: this is the common case, in situations like
+     length @alpha ([] @alpha)
+  It really doesn't matter what type we choose for alpha.  But
+  we must choose a type!  We can't leae mutable unification
+  variables floating around: after typecheck is complete, every
+  type variable occurrence must have a bindign site.
+
+  So we default it to 'Any' of the right kind.
+
+  All this works for both type and kind variables (indeed
+  the two are the same thign).
+
+* SkolemiseFlexi: is a special case for the LHS of RULES.
+  See Note [Zonking the LHS of a RULE]
+
+* RuntimeUnkFlexi: is a special case for the GHCi debugger.
+  It's a way to have a variable that is not a mutuable
+  unification variable, but doesn't have a binding site
+  either.
+-}
 
-instance Outputable ZonkEnv where
-  ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
+data ZonkFlexi   -- See Note [Un-unified unification variables]
+  = DefaultFlexi    -- Default unbound unificaiton variables to Any
+  | SkolemiseFlexi  -- Skolemise unbound unification variables
+                    -- See Note [Zonking the LHS of a RULE]
+  | RuntimeUnkFlexi -- Used in the GHCi debugger
 
+instance Outputable ZonkEnv where
+  ppr (ZonkEnv { ze_id_env =  var_env}) = pprUFM var_env (vcat . map ppr)
 
 -- The EvBinds have to already be zonked, but that's usually the case.
-emptyZonkEnv :: ZonkEnv
-emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping
+emptyZonkEnv :: TcM ZonkEnv
+emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
 
-mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
-mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
+mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
+mkEmptyZonkEnv flexi
+  = do { mtv_env_ref <- newTcRef emptyVarEnv
+       ; return (ZonkEnv { ze_flexi = flexi
+                         , ze_tv_env = emptyVarEnv
+                         , ze_id_env = emptyVarEnv
+                         , ze_meta_tv_env = mtv_env_ref }) }
+
+initZonkEnv :: (ZonkEnv -> a -> TcM b) -> a -> TcM b
+initZonkEnv do_it x = do { ze <- mkEmptyZonkEnv DefaultFlexi
+                         ; do_it ze x }
 
 -- | Extend the knot-tied environment.
 extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
-extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
+extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
     -- NB: Don't look at the var to decide which env't to put it in. That
     -- would end up knot-tying all the env'ts.
-  = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
+  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
   -- Given coercion variables will actually end up here. That's OK though:
   -- coercion variables are never looked up in the knot-tied env't, so zonking
   -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
@@ -242,29 +305,32 @@ extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
   -- more than the savings.
 
 extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
-extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars
-  = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])
-                    (extendVarEnvList id_env   [(id,id) | id <- ids])
-  where (tycovars, ids) = partition isTyCoVar vars
+extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
+  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
+       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }
+  where
+    (tycovars, ids) = partition isTyCoVar vars
 
 extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
-extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
-  = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
+extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id
+  = ze { ze_id_env = extendVarEnv id_env id id }
 
 extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
-extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
-  = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
+extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
+  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
 
-setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
-setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
-  = ZonkEnv zonk_ty ty_env id_env
+setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
+setZonkType ze flexi = ze { ze_flexi = flexi }
 
 zonkEnvIds :: ZonkEnv -> TypeEnv
-zonkEnvIds (ZonkEnv _ _ id_env) =
-  mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
+zonkEnvIds (ZonkEnv { ze_id_env = id_env})
+  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
   -- It's OK to use nonDetEltsUFM here because we forget the ordering
   -- immediately by creating a TypeEnv
 
+zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
+zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)
+
 zonkIdOcc :: ZonkEnv -> TcId -> Id
 -- Ids defined in this module should be in the envt;
 -- ignore others.  (Actually, data constructors are also
@@ -281,7 +347,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id
 --
 -- Even without template splices, in module Main, the checking of
 -- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
+zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
   | isLocalVar id = lookupVarEnv id_env id `orElse`
                     id
   | otherwise     = id
@@ -293,7 +359,7 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
 -- to its final form.  The TyVarEnv give
 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
 zonkIdBndr env v
-  = do ty' <- zonkTcTypeToType env (idType v)
+  = do ty' <- zonkTcTypeToTypeX env (idType v)
        ensureNotLevPoly ty'
          (text "In the type of binder" <+> quotes (ppr v))
 
@@ -303,10 +369,12 @@ zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
 
 zonkTopBndrs :: [TcId] -> TcM [Id]
-zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
+zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids
 
 zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
-zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel
+zonkFieldOcc env (FieldOcc sel lbl)
+  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
+zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
 
 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
 zonkEvBndrsX = mapAccumLM zonkEvBndrX
@@ -324,15 +392,29 @@ zonkEvBndr env var
   = do { let var_ty = varType var
        ; ty <-
            {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
-           zonkTcTypeToType env var_ty
+           zonkTcTypeToTypeX env var_ty
        ; return (setVarType var ty) }
 
+{-
 zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
 zonkEvVarOcc env v
   | isCoVar v
   = EvCoercion <$> zonkCoVarOcc env v
   | otherwise
   = return (EvId $ zonkIdOcc env v)
+-}
+
+zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
+zonkCoreBndrX env v
+  | isId v = do { v' <- zonkIdBndr env v
+                ; return (extendIdZonkEnv1 env v', v') }
+  | otherwise = zonkTyBndrX env v
+
+zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
+zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
+
+zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrs = initZonkEnv zonkTyBndrsX
 
 zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
 zonkTyBndrsX = mapAccumLM zonkTyBndrX
@@ -342,61 +424,63 @@ zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
 -- then we add it to the envt, so all occurrences are replaced
 zonkTyBndrX env tv
   = ASSERT( isImmutableTyVar tv )
-    do { ki <- zonkTcTypeToType env (tyVarKind tv)
+    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
                -- Internal names tidy up better, for iface files.
        ; let tv' = mkTyVar (tyVarName tv) ki
        ; return (extendTyZonkEnv1 env tv', tv') }
 
-zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
-                             -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
+zonkTyVarBinders ::  [VarBndr TcTyVar vis]
+                 -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBinders = initZonkEnv zonkTyVarBindersX
+
+zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
+                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
 zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
 
-zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
-                            -> TcM (ZonkEnv, TyVarBndr TyVar vis)
+zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
+                            -> TcM (ZonkEnv, VarBndr TyVar vis)
 -- Takes a TcTyVar and guarantees to return a TyVar
-zonkTyVarBinderX env (TvBndr tv vis)
+zonkTyVarBinderX env (Bndr tv vis)
   = do { (env', tv') <- zonkTyBndrX env tv
-       ; return (env', TvBndr tv' vis) }
+       ; return (env', Bndr tv' vis) }
 
 zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
-zonkTopExpr e = zonkExpr emptyZonkEnv e
+zonkTopExpr e = initZonkEnv zonkExpr e
 
 zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
-zonkTopLExpr e = zonkLExpr emptyZonkEnv e
+zonkTopLExpr e = initZonkEnv zonkLExpr e
 
 zonkTopDecls :: Bag EvBind
              -> LHsBinds GhcTcId
-             -> [LRuleDecl GhcTcId] -> [LVectDecl GhcTcId] -> [LTcSpecPrag]
+             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
              -> [LForeignDecl GhcTcId]
              -> TcM (TypeEnv,
                      Bag EvBind,
                      LHsBinds GhcTc,
                      [LForeignDecl GhcTc],
                      [LTcSpecPrag],
-                     [LRuleDecl    GhcTc],
-                     [LVectDecl    GhcTc])
-zonkTopDecls ev_binds binds rules vects imp_specs fords
-  = do  { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-        ; (env2, binds') <- zonkRecMonoBinds env1 binds
+                     [LRuleDecl    GhcTc])
+zonkTopDecls ev_binds binds rules imp_specs fords
+  = do  { (env1, ev_binds') <- initZonkEnv zonkEvBinds ev_binds
+        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
                         -- Top level is implicitly recursive
         ; rules' <- zonkRules env2 rules
-        ; vects' <- zonkVects env2 vects
         ; specs' <- zonkLTcSpecPrags env2 imp_specs
         ; fords' <- zonkForeignExports env2 fords
-        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
                -> TcM (ZonkEnv, HsLocalBinds GhcTc)
-zonkLocalBinds env EmptyLocalBinds
-  = return (env, EmptyLocalBinds)
+zonkLocalBinds env (EmptyLocalBinds x)
+  = return (env, (EmptyLocalBinds x))
 
-zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
+zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
   = panic "zonkLocalBinds" -- Not in typechecker output
 
-zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
+zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
   = do  { (env1, new_binds) <- go env binds
-        ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
+        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
   where
     go env []
       = return (env, [])
@@ -405,17 +489,24 @@ zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
            ; (env2, bs') <- go env1 bs
            ; return (env2, (r,b'):bs') }
 
-zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
+zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
     new_binds <- mapM (wrapLocM zonk_ip_bind) binds
     let
-        env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
+        env1 = extendIdZonkEnvRec env [ n
+                                      | L _ (IPBind _ (Right n) _) <- new_binds]
     (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
-    return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
+    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
   where
-    zonk_ip_bind (IPBind n e)
+    zonk_ip_bind (IPBind x n e)
         = do n' <- mapIPNameTc (zonkIdBndr env) n
              e' <- zonkLExpr env e
-             return (IPBind n' e')
+             return (IPBind x n' e')
+    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
+
+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+zonkLocalBinds _ (XHsLocalBindsLR _)
+  = panic "zonkLocalBinds" -- Not in typechecker output
 
 ---------------------------------------------
 zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
@@ -433,16 +524,22 @@ zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
 zonk_lbind env = wrapLocM (zonk_bind env)
 
 zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
+                            , pat_ext = NPatBindTc fvs ty})
   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
         ; new_grhss <- zonkGRHSs env zonkLExpr grhss
-        ; new_ty    <- zonkTcTypeToType env ty
-        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
+        ; new_ty    <- zonkTcTypeToTypeX env ty
+        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
+                       , pat_ext = NPatBindTc fvs new_ty }) }
 
-zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
+zonk_bind env (VarBind { var_ext = x
+                       , var_id = var, var_rhs = expr, var_inline = inl })
   = do { new_var  <- zonkIdBndr env var
        ; new_expr <- zonkLExpr env expr
-       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
+       ; return (VarBind { var_ext = x
+                         , var_id = new_var
+                         , var_rhs = new_expr
+                         , var_inline = inl }) }
 
 zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                             , fun_co_fn = co_fn })
@@ -455,92 +552,86 @@ zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abs_ev_binds = ev_binds
                         , abs_exports = exports
-                        , abs_binds = val_binds })
+                        , abs_binds = val_binds
+                        , abs_sig = has_sig })
   = ASSERT( all isImmutableTyVar tyvars )
     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
-         do { let env3 = extendIdZonkEnvRec env2
-                           (collectHsBindsBinders new_val_binds)
-            ; new_val_binds <- zonkMonoBinds env3 val_binds
-            ; new_exports   <- mapM (zonkExport env3) exports
+         do { let env3 = extendIdZonkEnvRec env2 $
+                         collectHsBindsBinders new_val_binds
+            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+            ; new_exports   <- mapM (zonk_export env3) exports
             ; return (new_val_binds, new_exports) }
-       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
+       ; return (AbsBinds { abs_ext = noExt
+                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
                           , abs_ev_binds = new_ev_binds
-                          , abs_exports = new_exports, abs_binds = new_val_bind }) }
+                          , abs_exports = new_exports, abs_binds = new_val_bind
+                          , abs_sig = has_sig }) }
   where
-    zonkExport env (ABE{ abe_wrap = wrap
-                       , abe_poly = poly_id
-                       , abe_mono = mono_id, abe_prags = prags })
+    zonk_val_bind env lbind
+      | has_sig
+      , L loc bind@(FunBind { fun_id      = L mloc mono_id
+                            , fun_matches = ms
+                            , fun_co_fn   = co_fn }) <- lbind
+      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
+                            -- Specifically /not/ zonkIdBndr; we do not
+                            -- want to complain about a levity-polymorphic binder
+           ; (env', new_co_fn) <- zonkCoFn env co_fn
+           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
+           ; return $ L loc $
+             bind { fun_id      = L mloc new_mono_id
+                  , fun_matches = new_ms
+                  , fun_co_fn   = new_co_fn } }
+      | otherwise
+      = zonk_lbind env lbind   -- The normal case
+
+    zonk_export env (ABE{ abe_ext = x
+                        , abe_wrap = wrap
+                        , abe_poly = poly_id
+                        , abe_mono = mono_id
+                        , abe_prags = prags })
         = do new_poly_id <- zonkIdBndr env poly_id
              (_, new_wrap) <- zonkCoFn env wrap
              new_prags <- zonkSpecPrags env prags
-             return (ABE{ abe_wrap = new_wrap
+             return (ABE{ abe_ext = x
+                        , abe_wrap = new_wrap
                         , abe_poly = new_poly_id
                         , abe_mono = zonkIdOcc env mono_id
                         , abe_prags = new_prags })
+    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
 
-zonk_bind env outer_bind@(AbsBindsSig { abs_tvs         = tyvars
-                                      , abs_ev_vars     = evs
-                                      , abs_sig_export  = poly
-                                      , abs_sig_prags   = prags
-                                      , abs_sig_ev_bind = ev_bind
-                                      , abs_sig_bind    = lbind })
-  | L bind_loc bind@(FunBind { fun_id      = L loc local
-                             , fun_matches = ms
-                             , fun_co_fn   = co_fn }) <- lbind
-  = ASSERT( all isImmutableTyVar tyvars )
-    do { (env0, new_tyvars)  <- zonkTyBndrsX env  tyvars
-       ; (env1, new_evs)     <- zonkEvBndrsX env0 evs
-       ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
-           -- Inline zonk_bind (FunBind ...) because we wish to skip
-           -- the check for representation-polymorphic binders. The
-           -- local binder in the FunBind in an AbsBindsSig is never actually
-           -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
-           -- just calling zonk_bind causes #11405.
-       ; new_local           <- updateVarTypeM (zonkTcTypeToType env2) local
-       ; (env3, new_co_fn)   <- zonkCoFn env2 co_fn
-       ; new_ms              <- zonkMatchGroup env3 zonkLExpr ms
-           -- If there is a representation polymorphism problem, it will
-           -- be caught here:
-       ; new_poly_id         <- zonkIdBndr env2 poly
-       ; new_prags           <- zonkSpecPrags env2 prags
-       ; let new_val_bind = L bind_loc (bind { fun_id      = L loc new_local
-                                             , fun_matches = new_ms
-                                             , fun_co_fn   = new_co_fn })
-       ; return (AbsBindsSig { abs_tvs         = new_tyvars
-                             , abs_ev_vars     = new_evs
-                             , abs_sig_export  = new_poly_id
-                             , abs_sig_prags   = new_prags
-                             , abs_sig_ev_bind = new_ev_bind
-                             , abs_sig_bind    = new_val_bind  }) }
-
-  | otherwise
-  = pprPanic "zonk_bind" (ppr outer_bind)
-
-zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
-                                    , psb_args = details
-                                    , psb_def = lpat
-                                    , psb_dir = dir }))
+zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
+                                      , psb_args = details
+                                      , psb_def = lpat
+                                      , psb_dir = dir }))
   = do { id' <- zonkIdBndr env id
-       ; details' <- zonkPatSynDetails env details
        ; (env1, lpat') <- zonkPat env lpat
+       ; let details' = zonkPatSynDetails env1 details
        ; (_env2, dir') <- zonkPatSynDir env1 dir
-       ; return $ PatSynBind $
+       ; return $ PatSynBind x $
                   bind { psb_id = L loc id'
                        , psb_args = details'
                        , psb_def = lpat'
                        , psb_dir = dir' } }
 
+zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
+zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"
+
 zonkPatSynDetails :: ZonkEnv
                   -> HsPatSynDetails (Located TcId)
-                  -> TcM (HsPatSynDetails (Located Id))
-zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
+                  -> HsPatSynDetails (Located Id)
+zonkPatSynDetails env (PrefixCon as)
+  = PrefixCon (map (zonkLIdOcc env) as)
+zonkPatSynDetails env (InfixCon a1 a2)
+  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+zonkPatSynDetails env (RecCon flds)
+  = RecCon (map (fmap (zonkLIdOcc env)) flds)
 
 zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
               -> TcM (ZonkEnv, HsPatSynDir GhcTc)
-zonkPatSynDir env Unidirectional = return (env, Unidirectional)
+zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
 zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
 zonkPatSynDir env (ExplicitBidirectional mg) = do
     mg' <- zonkMatchGroup env zonkLExpr mg
@@ -571,22 +662,26 @@ zonkMatchGroup :: ZonkEnv
             -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
             -> MatchGroup GhcTcId (Located (body GhcTcId))
             -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
-zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
-                             , mg_res_ty = res_ty, mg_origin = origin })
+zonkMatchGroup env zBody (MG { mg_alts = L l ms
+                             , mg_ext = MatchGroupTc arg_tys res_ty
+                             , mg_origin = origin })
   = do  { ms' <- mapM (zonkMatch env zBody) ms
-        ; arg_tys' <- zonkTcTypeToTypes env arg_tys
-        ; res_ty'  <- zonkTcTypeToType env res_ty
-        ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
-                     , mg_res_ty = res_ty', mg_origin = origin }) }
+        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
+        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
+        ; return (MG { mg_alts = L l ms'
+                     , mg_ext = MatchGroupTc arg_tys' res_ty'
+                     , mg_origin = origin }) }
+zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
 
 zonkMatch :: ZonkEnv
           -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
           -> LMatch GhcTcId (Located (body GhcTcId))
           -> TcM (LMatch GhcTc (Located (body GhcTc)))
-zonkMatch env zBody (L loc (Match mf pats _ grhss))
+zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss }))
   = do  { (env1, new_pats) <- zonkPats env pats
         ; new_grhss <- zonkGRHSs env1 zBody grhss
-        ; return (L loc (Match mf new_pats Nothing new_grhss)) }
+        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
+zonkMatch _ _ (L  _ (XMatch _)) = panic "zonkMatch"
 
 -------------------------------------------------------------------------
 zonkGRHSs :: ZonkEnv
@@ -594,15 +689,17 @@ zonkGRHSs :: ZonkEnv
           -> GRHSs GhcTcId (Located (body GhcTcId))
           -> TcM (GRHSs GhcTc (Located (body GhcTc)))
 
-zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
+zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
     (new_env, new_binds) <- zonkLocalBinds env binds
     let
-        zonk_grhs (GRHS guarded rhs)
+        zonk_grhs (GRHS xx guarded rhs)
           = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
                new_rhs <- zBody env2 rhs
-               return (GRHS new_guarded new_rhs)
+               return (GRHS xx new_guarded new_rhs)
+        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
     new_grhss <- mapM (wrapLocM zonk_grhs) grhss
-    return (GRHSs new_grhss (L l new_binds))
+    return (GRHSs x new_grhss (L l new_binds))
+zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
 
 {-
 ************************************************************************
@@ -619,169 +716,170 @@ zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
 zonkLExprs env exprs = mapM (zonkLExpr env) exprs
 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
 
-zonkExpr env (HsVar (L l id))
+zonkExpr env (HsVar x (L l id))
   = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
-    return (HsVar (L l (zonkIdOcc env id)))
+    return (HsVar x (L l (zonkIdOcc env id)))
 
 zonkExpr _ e@(HsConLikeOut {}) = return e
 
-zonkExpr _ (HsIPVar id)
-  = return (HsIPVar id)
+zonkExpr _ (HsIPVar x id)
+  = return (HsIPVar x id)
 
 zonkExpr _ e@HsOverLabel{} = return e
 
-zonkExpr env (HsLit (HsRat e f ty))
-  = do new_ty <- zonkTcTypeToType env ty
-       return (HsLit (HsRat e f new_ty))
+zonkExpr env (HsLit x (HsRat e f ty))
+  = do new_ty <- zonkTcTypeToTypeX env ty
+       return (HsLit x (HsRat e f new_ty))
 
-zonkExpr _ (HsLit lit)
-  = return (HsLit lit)
+zonkExpr _ (HsLit x lit)
+  = return (HsLit x lit)
 
-zonkExpr env (HsOverLit lit)
+zonkExpr env (HsOverLit x lit)
   = do  { lit' <- zonkOverLit env lit
-        ; return (HsOverLit lit') }
+        ; return (HsOverLit x lit') }
 
-zonkExpr env (HsLam matches)
+zonkExpr env (HsLam x matches)
   = do new_matches <- zonkMatchGroup env zonkLExpr matches
-       return (HsLam new_matches)
+       return (HsLam x new_matches)
 
-zonkExpr env (HsLamCase matches)
+zonkExpr env (HsLamCase x matches)
   = do new_matches <- zonkMatchGroup env zonkLExpr matches
-       return (HsLamCase new_matches)
+       return (HsLamCase x new_matches)
 
-zonkExpr env (HsApp e1 e2)
+zonkExpr env (HsApp x e1 e2)
   = do new_e1 <- zonkLExpr env e1
        new_e2 <- zonkLExpr env e2
-       return (HsApp new_e1 new_e2)
+       return (HsApp x new_e1 new_e2)
 
-zonkExpr env (HsAppTypeOut e t)
+zonkExpr env (HsAppType t e)
   = do new_e <- zonkLExpr env e
-       return (HsAppTypeOut new_e t)
+       return (HsAppType t new_e)
        -- NB: the type is an HsType; can't zonk that!
 
-zonkExpr _ e@(HsRnBracketOut _ _)
+zonkExpr _ e@(HsRnBracketOut _ _ _)
   = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
 
-zonkExpr env (HsTcBracketOut body bs)
+zonkExpr env (HsTcBracketOut x body bs)
   = do bs' <- mapM zonk_b bs
-       return (HsTcBracketOut body bs')
+       return (HsTcBracketOut x body bs')
   where
     zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
                                       return (PendingTcSplice n e')
 
-zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
-                           return (HsSpliceE s)
+zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
+                           return (HsSpliceE x s)
 
-zonkExpr env (OpApp e1 op fixity e2)
+zonkExpr env (OpApp fixity e1 op e2)
   = do new_e1 <- zonkLExpr env e1
        new_op <- zonkLExpr env op
        new_e2 <- zonkLExpr env e2
-       return (OpApp new_e1 new_op fixity new_e2)
+       return (OpApp fixity new_e1 new_op new_e2)
 
-zonkExpr env (NegApp expr op)
+zonkExpr env (NegApp x expr op)
   = do (env', new_op) <- zonkSyntaxExpr env op
        new_expr <- zonkLExpr env' expr
-       return (NegApp new_expr new_op)
+       return (NegApp x new_expr new_op)
 
-zonkExpr env (HsPar e)
+zonkExpr env (HsPar x e)
   = do new_e <- zonkLExpr env e
-       return (HsPar new_e)
+       return (HsPar x new_e)
 
-zonkExpr env (SectionL expr op)
+zonkExpr env (SectionL x expr op)
   = do new_expr <- zonkLExpr env expr
        new_op   <- zonkLExpr env op
-       return (SectionL new_expr new_op)
+       return (SectionL x new_expr new_op)
 
-zonkExpr env (SectionR op expr)
+zonkExpr env (SectionR x op expr)
   = do new_op   <- zonkLExpr env op
        new_expr <- zonkLExpr env expr
-       return (SectionR new_op new_expr)
+       return (SectionR x new_op new_expr)
 
-zonkExpr env (ExplicitTuple tup_args boxed)
+zonkExpr env (ExplicitTuple x tup_args boxed)
   = do { new_tup_args <- mapM zonk_tup_arg tup_args
-       ; return (ExplicitTuple new_tup_args boxed) }
+       ; return (ExplicitTuple x new_tup_args boxed) }
   where
-    zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
-                                        ; return (L l (Present e')) }
-    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
+    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e
+                                          ; return (L l (Present x e')) }
+    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
                                         ; return (L l (Missing t')) }
+    zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
 
-zonkExpr env (ExplicitSum alt arity expr args)
-  = do new_args <- mapM (zonkTcTypeToType env) args
+zonkExpr env (ExplicitSum args alt arity expr)
+  = do new_args <- mapM (zonkTcTypeToTypeX env) args
        new_expr <- zonkLExpr env expr
-       return (ExplicitSum alt arity new_expr new_args)
+       return (ExplicitSum new_args alt arity new_expr)
 
-zonkExpr env (HsCase expr ms)
+zonkExpr env (HsCase x expr ms)
   = do new_expr <- zonkLExpr env expr
        new_ms <- zonkMatchGroup env zonkLExpr ms
-       return (HsCase new_expr new_ms)
+       return (HsCase x new_expr new_ms)
 
-zonkExpr env (HsIf Nothing e1 e2 e3)
+zonkExpr env (HsIf x Nothing e1 e2 e3)
   = do new_e1 <- zonkLExpr env e1
        new_e2 <- zonkLExpr env e2
        new_e3 <- zonkLExpr env e3
-       return (HsIf Nothing new_e1 new_e2 new_e3)
+       return (HsIf x Nothing new_e1 new_e2 new_e3)
 
-zonkExpr env (HsIf (Just fun) e1 e2 e3)
+zonkExpr env (HsIf x (Just fun) e1 e2 e3)
   = do (env1, new_fun) <- zonkSyntaxExpr env fun
        new_e1 <- zonkLExpr env1 e1
        new_e2 <- zonkLExpr env1 e2
        new_e3 <- zonkLExpr env1 e3
-       return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
+       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
 
 zonkExpr env (HsMultiIf ty alts)
   = do { alts' <- mapM (wrapLocM zonk_alt) alts
-       ; ty'   <- zonkTcTypeToType env ty
+       ; ty'   <- zonkTcTypeToTypeX env ty
        ; return $ HsMultiIf ty' alts' }
-  where zonk_alt (GRHS guard expr)
+  where zonk_alt (GRHS x guard expr)
           = do { (env', guard') <- zonkStmts env zonkLExpr guard
                ; expr'          <- zonkLExpr env' expr
-               ; return $ GRHS guard' expr' }
+               ; return $ GRHS x guard' expr' }
+        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
 
-zonkExpr env (HsLet (L l binds) expr)
+zonkExpr env (HsLet x (L l binds) expr)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_expr <- zonkLExpr new_env expr
-       return (HsLet (L l new_binds) new_expr)
+       return (HsLet x (L l new_binds) new_expr)
 
-zonkExpr env (HsDo do_or_lc (L l stmts) ty)
+zonkExpr env (HsDo ty do_or_lc (L l stmts))
   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
-       new_ty <- zonkTcTypeToType env ty
-       return (HsDo do_or_lc (L l new_stmts) new_ty)
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsDo new_ty do_or_lc (L l new_stmts))
 
 zonkExpr env (ExplicitList ty wit exprs)
   = do (env1, new_wit) <- zonkWit env wit
-       new_ty <- zonkTcTypeToType env1 ty
+       new_ty <- zonkTcTypeToTypeX env1 ty
        new_exprs <- zonkLExprs env1 exprs
        return (ExplicitList new_ty new_wit new_exprs)
    where zonkWit env Nothing    = return (env, Nothing)
          zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
-zonkExpr env (ExplicitPArr ty exprs)
-  = do new_ty <- zonkTcTypeToType env ty
-       new_exprs <- zonkLExprs env exprs
-       return (ExplicitPArr new_ty new_exprs)
-
-zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
-  = do  { new_con_expr <- zonkExpr env con_expr
+zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
+  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
         ; new_rbinds   <- zonkRecFields env rbinds
-        ; return (expr { rcon_con_expr = new_con_expr
+        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
                        , rcon_flds = new_rbinds }) }
 
-zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
-                        , rupd_cons = cons, rupd_in_tys = in_tys
-                        , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
+zonkExpr env (RecordUpd { rupd_flds = rbinds
+                        , rupd_expr = expr
+                        , rupd_ext = RecordUpdTc
+                            { rupd_cons = cons, rupd_in_tys = in_tys
+                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
   = do  { new_expr    <- zonkLExpr env expr
-        ; new_in_tys  <- mapM (zonkTcTypeToType env) in_tys
-        ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
+        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys
+        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
         ; new_rbinds  <- zonkRecUpdFields env rbinds
         ; (_, new_recwrap) <- zonkCoFn env req_wrap
         ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
-                            , rupd_cons = cons, rupd_in_tys = new_in_tys
-                            , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
+                            , rupd_ext = RecordUpdTc
+                                { rupd_cons = cons, rupd_in_tys = new_in_tys
+                                , rupd_out_tys = new_out_tys
+                                , rupd_wrap = new_recwrap }}) }
 
-zonkExpr env (ExprWithTySigOut e ty)
+zonkExpr env (ExprWithTySig ty e)
   = do { e' <- zonkLExpr env e
-       ; return (ExprWithTySigOut e' ty) }
+       ; return (ExprWithTySig ty e') }
 
 zonkExpr env (ArithSeq expr wit info)
   = do (env1, new_wit) <- zonkWit env wit
@@ -791,38 +889,33 @@ zonkExpr env (ArithSeq expr wit info)
    where zonkWit env Nothing    = return (env, Nothing)
          zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
-zonkExpr env (PArrSeq expr info)
-  = do new_expr <- zonkExpr env expr
-       new_info <- zonkArithSeq env info
-       return (PArrSeq new_expr new_info)
-
-zonkExpr env (HsSCC src lbl expr)
+zonkExpr env (HsSCC x src lbl expr)
   = do new_expr <- zonkLExpr env expr
-       return (HsSCC src lbl new_expr)
+       return (HsSCC x src lbl new_expr)
 
-zonkExpr env (HsTickPragma src info srcInfo expr)
+zonkExpr env (HsTickPragma x src info srcInfo expr)
   = do new_expr <- zonkLExpr env expr
-       return (HsTickPragma src info srcInfo new_expr)
+       return (HsTickPragma x src info srcInfo new_expr)
 
 -- hdaume: core annotations
-zonkExpr env (HsCoreAnn src lbl expr)
+zonkExpr env (HsCoreAnn x src lbl expr)
   = do new_expr <- zonkLExpr env expr
-       return (HsCoreAnn src lbl new_expr)
+       return (HsCoreAnn x src lbl new_expr)
 
 -- arrow notation extensions
-zonkExpr env (HsProc pat body)
+zonkExpr env (HsProc x pat body)
   = do  { (env1, new_pat) <- zonkPat env pat
         ; new_body <- zonkCmdTop env1 body
-        ; return (HsProc new_pat new_body) }
+        ; return (HsProc x new_pat new_body) }
 
 -- StaticPointers extension
 zonkExpr env (HsStatic fvs expr)
   = HsStatic fvs <$> zonkLExpr env expr
 
-zonkExpr env (HsWrap co_fn expr)
+zonkExpr env (HsWrap x co_fn expr)
   = do (env1, new_co_fn) <- zonkCoFn env co_fn
        new_expr <- zonkExpr env1 expr
-       return (HsWrap new_co_fn new_expr)
+       return (HsWrap x new_co_fn new_expr)
 
 zonkExpr _ e@(HsUnboundVar {}) = return e
 
@@ -869,60 +962,60 @@ zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
 
 zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd
 
-zonkCmd env (HsCmdWrap w cmd)
+zonkCmd env (HsCmdWrap x w cmd)
   = do { (env1, w') <- zonkCoFn env w
        ; cmd' <- zonkCmd env1 cmd
-       ; return (HsCmdWrap w' cmd') }
-zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
+       ; return (HsCmdWrap x w' cmd') }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
   = do new_e1 <- zonkLExpr env e1
        new_e2 <- zonkLExpr env e2
-       new_ty <- zonkTcTypeToType env ty
-       return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
 
-zonkCmd env (HsCmdArrForm op f fixity args)
+zonkCmd env (HsCmdArrForm x op f fixity args)
   = do new_op <- zonkLExpr env op
        new_args <- mapM (zonkCmdTop env) args
-       return (HsCmdArrForm new_op f fixity new_args)
+       return (HsCmdArrForm x new_op f fixity new_args)
 
-zonkCmd env (HsCmdApp c e)
+zonkCmd env (HsCmdApp x c e)
   = do new_c <- zonkLCmd env c
        new_e <- zonkLExpr env e
-       return (HsCmdApp new_c new_e)
+       return (HsCmdApp x new_c new_e)
 
-zonkCmd env (HsCmdLam matches)
+zonkCmd env (HsCmdLam x matches)
   = do new_matches <- zonkMatchGroup env zonkLCmd matches
-       return (HsCmdLam new_matches)
+       return (HsCmdLam x new_matches)
 
-zonkCmd env (HsCmdPar c)
+zonkCmd env (HsCmdPar x c)
   = do new_c <- zonkLCmd env c
-       return (HsCmdPar new_c)
+       return (HsCmdPar x new_c)
 
-zonkCmd env (HsCmdCase expr ms)
+zonkCmd env (HsCmdCase x expr ms)
   = do new_expr <- zonkLExpr env expr
        new_ms <- zonkMatchGroup env zonkLCmd ms
-       return (HsCmdCase new_expr new_ms)
+       return (HsCmdCase x new_expr new_ms)
 
-zonkCmd env (HsCmdIf eCond ePred cThen cElse)
+zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
   = do { (env1, new_eCond) <- zonkWit env eCond
        ; new_ePred <- zonkLExpr env1 ePred
        ; new_cThen <- zonkLCmd env1 cThen
        ; new_cElse <- zonkLCmd env1 cElse
-       ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
+       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
   where
     zonkWit env Nothing  = return (env, Nothing)
     zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
 
-zonkCmd env (HsCmdLet (L l binds) cmd)
+zonkCmd env (HsCmdLet x (L l binds) cmd)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
        new_cmd <- zonkLCmd new_env cmd
-       return (HsCmdLet (L l new_binds) new_cmd)
+       return (HsCmdLet x (L l new_binds) new_cmd)
 
-zonkCmd env (HsCmdDo (L l stmts) ty)
+zonkCmd env (HsCmdDo ty (L l stmts))
   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
-       new_ty <- zonkTcTypeToType env ty
-       return (HsCmdDo (L l new_stmts) new_ty)
-
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdDo new_ty (L l new_stmts))
 
+zonkCmd _ (XCmd{}) = panic "zonkCmd"
 
 
 
@@ -930,10 +1023,10 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
 
 zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
-zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
   = do new_cmd <- zonkLCmd env cmd
-       new_stack_tys <- zonkTcTypeToType env stack_tys
-       new_ty <- zonkTcTypeToType env ty
+       new_stack_tys <- zonkTcTypeToTypeX env stack_tys
+       new_ty <- zonkTcTypeToTypeX env ty
        new_ids <- mapSndM (zonkExpr env) ids
 
        MASSERT( isLiftedTypeKind (typeKind new_stack_tys) )
@@ -941,7 +1034,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
          -- but indeed it should always be lifted due to the typing
          -- rules for arrows
 
-       return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
 
 -------------------------------------------------------------------------
 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
@@ -951,7 +1045,7 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
                                     ; return (env2, WpCompose c1' c2') }
 zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
                                      ; (env2, c2') <- zonkCoFn env1 c2
-                                     ; t1'         <- zonkTcTypeToType env2 t1
+                                     ; t1'         <- zonkTcTypeToTypeX env2 t1
                                      ; return (env2, WpFun c1' c2' t1' d) }
 zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
                               ; return (env, WpCast co') }
@@ -962,17 +1056,19 @@ zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
                               do { (env', tv') <- zonkTyBndrX env tv
                                  ; return (env', WpTyLam tv') }
-zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty
                                  ; return (env, WpTyApp ty') }
 zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
                                  ; return (env1, WpLet bs') }
 
 -------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
-zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
-  = do  { ty' <- zonkTcTypeToType env ty
+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+  = do  { ty' <- zonkTcTypeToTypeX env ty
         ; e' <- zonkExpr env e
-        ; return (lit { ol_witness = e', ol_type = ty' }) }
+        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+
+zonkOverLit _ XOverLit{} = panic "zonkOverLit"
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
@@ -1012,32 +1108,39 @@ zonkStmt :: ZonkEnv
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> Stmt GhcTcId (Located (body GhcTcId))
          -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
-zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
+zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
   = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
-       ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
+       ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
        ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
-       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
+       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+                              , b <- bs]
              env2 = extendIdZonkEnvRec env1 new_binders
        ; new_mzip <- zonkExpr env2 mzip_op
-       ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
+       ; return (env2
+                , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
   where
-    zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
+    zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
        = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
             ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
-            ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
+            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+                                                                   new_return) }
+    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
 
 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                             , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
-                            , recS_bind_fn = bind_id, recS_bind_ty = bind_ty
-                            , recS_later_rets = later_rets, recS_rec_rets = rec_rets
-                            , recS_ret_ty = ret_ty })
+                            , recS_bind_fn = bind_id
+                            , recS_ext =
+                                       RecStmtTc { recS_bind_ty = bind_ty
+                                                 , recS_later_rets = later_rets
+                                                 , recS_rec_rets = rec_rets
+                                                 , recS_ret_ty = ret_ty} })
   = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
        ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
        ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id
-       ; new_bind_ty <- zonkTcTypeToType env3 bind_ty
+       ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
        ; new_rvs <- zonkIdBndrs env3 rvs
        ; new_lvs <- zonkIdBndrs env3 lvs
-       ; new_ret_ty  <- zonkTcTypeToType env3 ret_ty
+       ; new_ret_ty  <- zonkTcTypeToTypeX env3 ret_ty
        ; let env4 = extendIdZonkEnvRec env3 new_rvs
        ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
         -- Zonk the ret-expressions in an envt that
@@ -1048,30 +1151,32 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
-                         , recS_bind_ty = new_bind_ty
-                         , recS_later_rets = new_later_rets
-                         , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
+                         , recS_ext = RecStmtTc
+                             { recS_bind_ty = new_bind_ty
+                             , recS_later_rets = new_later_rets
+                             , recS_rec_rets = new_rec_rets
+                             , recS_ret_ty = new_ret_ty } }) }
 
-zonkStmt env zBody (BodyStmt body then_op guard_op ty)
+zonkStmt env zBody (BodyStmt ty body then_op guard_op)
   = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op
        (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
        new_body <- zBody env2 body
-       new_ty   <- zonkTcTypeToType env2 ty
-       return (env2, BodyStmt new_body new_then_op new_guard_op new_ty)
+       new_ty   <- zonkTcTypeToTypeX env2 ty
+       return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
 
-zonkStmt env zBody (LastStmt body noret ret_op)
+zonkStmt env zBody (LastStmt x body noret ret_op)
   = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
        new_body <- zBody env1 body
-       return (env, LastStmt new_body noret new_ret)
+       return (env, LastStmt x new_body noret new_ret)
 
 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
                           , trS_by = by, trS_form = form, trS_using = using
                           , trS_ret = return_op, trS_bind = bind_op
-                          , trS_bind_arg_ty = bind_arg_ty
+                          , trS_ext = bind_arg_ty
                           , trS_fmap = liftM_op })
   = do {
     ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
-    ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty
+    ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
     ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
     ; by'        <- fmapMaybeM (zonkLExpr env2) by
     ; using'     <- zonkLExpr env2 using
@@ -1083,7 +1188,7 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
     ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                                , trS_by = by', trS_form = form, trS_using = using'
                                , trS_ret = return_op', trS_bind = bind_op'
-                               , trS_bind_arg_ty = bind_arg_ty'
+                               , trS_ext = bind_arg_ty'
                                , trS_fmap = liftM_op' }) }
   where
     zonkBinderMapEntry env  (oldBinder, newBinder) = do
@@ -1091,36 +1196,39 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
         newBinder' <- zonkIdBndr env newBinder
         return (oldBinder', newBinder')
 
-zonkStmt env _ (LetStmt (L l binds))
+zonkStmt env _ (LetStmt x (L l binds))
   = do (env1, new_binds) <- zonkLocalBinds env binds
-       return (env1, LetStmt (L l new_binds))
+       return (env1, LetStmt x (L l new_binds))
 
-zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty)
+zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
   = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
-        ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
+        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
         ; new_body <- zBody env1 body
         ; (env2, new_pat) <- zonkPat env1 pat
         ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
-        ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) }
+        ; return ( env2
+                 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
 
 -- Scopes: join > ops (in reverse order) > pats (in forward order)
 --              > rest of stmts
-zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
+zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
   = do  { (env1, new_mb_join)   <- zonk_join env mb_join
         ; (env2, new_args)      <- zonk_args env1 args
-        ; new_body_ty           <- zonkTcTypeToType env2 body_ty
-        ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) }
+        ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
+        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }
   where
     zonk_join env Nothing  = return (env, Nothing)
     zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
 
-    get_pat (_, ApplicativeArgOne pat _)    = pat
-    get_pat (_, ApplicativeArgMany _ _ pat) = pat
+    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
+    get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
+    get_pat (_, XApplicativeArg _) = panic "zonkStmt"
 
-    replace_pat pat (op, ApplicativeArgOne _ a)
-      = (op, ApplicativeArgOne pat a)
-    replace_pat pat (op, ApplicativeArgMany a b _)
-      = (op, ApplicativeArgMany a b pat)
+    replace_pat pat (op, ApplicativeArgOne x _ a isBody)
+      = (op, ApplicativeArgOne x pat a isBody)
+    replace_pat pat (op, ApplicativeArgMany x a b _)
+      = (op, ApplicativeArgMany x a b pat)
+    replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"
 
     zonk_args env args
       = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
@@ -1137,13 +1245,16 @@ zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
            ; return (env2, (new_op, new_arg) : new_args) }
     zonk_args_rev env [] = return (env, [])
 
-    zonk_arg env (ApplicativeArgOne pat expr)
+    zonk_arg env (ApplicativeArgOne x pat expr isBody)
       = do { new_expr <- zonkLExpr env expr
-           ; return (ApplicativeArgOne pat new_expr) }
-    zonk_arg env (ApplicativeArgMany stmts ret pat)
+           ; return (ApplicativeArgOne x pat new_expr isBody) }
+    zonk_arg env (ApplicativeArgMany x stmts ret pat)
       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
            ; new_ret           <- zonkExpr env1 ret
-           ; return (ApplicativeArgMany new_stmts new_ret pat) }
+           ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+    zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"
+
+zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"
 
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
@@ -1189,72 +1300,67 @@ zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
 
 zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
-zonk_pat env (ParPat p)
+zonk_pat env (ParPat x p)
   = do  { (env', p') <- zonkPat env p
-        ; return (env', ParPat p') }
+        ; return (env', ParPat x p') }
 
 zonk_pat env (WildPat ty)
-  = do  { ty' <- zonkTcTypeToType env ty
+  = do  { ty' <- zonkTcTypeToTypeX env ty
         ; ensureNotLevPoly ty'
             (text "In a wildcard pattern")
         ; return (env, WildPat ty') }
 
-zonk_pat env (VarPat (L l v))
+zonk_pat env (VarPat x (L l v))
   = do  { v' <- zonkIdBndr env v
-        ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }
+        ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) }
 
-zonk_pat env (LazyPat pat)
+zonk_pat env (LazyPat x pat)
   = do  { (env', pat') <- zonkPat env pat
-        ; return (env',  LazyPat pat') }
+        ; return (env',  LazyPat x pat') }
 
-zonk_pat env (BangPat pat)
+zonk_pat env (BangPat x pat)
   = do  { (env', pat') <- zonkPat env pat
-        ; return (env',  BangPat pat') }
+        ; return (env',  BangPat x pat') }
 
-zonk_pat env (AsPat (L loc v) pat)
+zonk_pat env (AsPat x (L loc v) pat)
   = do  { v' <- zonkIdBndr env v
         ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
-        ; return (env', AsPat (L loc v') pat') }
+        ; return (env', AsPat x (L loc v') pat') }
 
-zonk_pat env (ViewPat expr pat ty)
+zonk_pat env (ViewPat ty expr pat)
   = do  { expr' <- zonkLExpr env expr
         ; (env', pat') <- zonkPat env pat
-        ; ty' <- zonkTcTypeToType env ty
-        ; return (env', ViewPat expr' pat' ty') }
+        ; ty' <- zonkTcTypeToTypeX env ty
+        ; return (env', ViewPat ty' expr' pat') }
 
-zonk_pat env (ListPat pats ty Nothing)
-  = do  { ty' <- zonkTcTypeToType env ty
+zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pats') <- zonkPats env pats
-        ; return (env', ListPat pats' ty' Nothing) }
+        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
 
-zonk_pat env (ListPat pats ty (Just (ty2,wit)))
+zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
   = do  { (env', wit') <- zonkSyntaxExpr env wit
-        ; ty2' <- zonkTcTypeToType env' ty2
-        ; ty' <- zonkTcTypeToType env' ty
+        ; ty2' <- zonkTcTypeToTypeX env' ty2
+        ; ty' <- zonkTcTypeToTypeX env' ty
         ; (env'', pats') <- zonkPats env' pats
-        ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }
-
-zonk_pat env (PArrPat pats ty)
-  = do  { ty' <- zonkTcTypeToType env ty
-        ; (env', pats') <- zonkPats env pats
-        ; return (env', PArrPat pats' ty') }
+        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
 
-zonk_pat env (TuplePat pats boxed tys)
-  = do  { tys' <- mapM (zonkTcTypeToType env) tys
+zonk_pat env (TuplePat tys pats boxed)
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
         ; (env', pats') <- zonkPats env pats
-        ; return (env', TuplePat pats' boxed tys') }
+        ; return (env', TuplePat tys' pats' boxed) }
 
-zonk_pat env (SumPat pat alt arity tys)
-  = do  { tys' <- mapM (zonkTcTypeToType env) tys
+zonk_pat env (SumPat tys pat alt arity )
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
         ; (env', pat') <- zonkPat env pat
-        ; return (env', SumPat pat' alt arity tys') }
+        ; return (env', SumPat tys' pat' alt arity) }
 
 zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
                           , pat_dicts = evs, pat_binds = binds
                           , pat_args = args, pat_wrap = wrapper
                           , pat_con = L _ con })
   = ASSERT( all isImmutableTyVar tyvars )
-    do  { new_tys <- mapM (zonkTcTypeToType env) tys
+    do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
 
           -- an unboxed tuple pattern (but only an unboxed tuple pattern)
           -- might have levity-polymorphic arguments. Check for this badness.
@@ -1281,38 +1387,38 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
   where
     doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
 
-zonk_pat env (LitPat lit) = return (env, LitPat lit)
+zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
 
-zonk_pat env (SigPatOut pat ty)
-  = do  { ty' <- zonkTcTypeToType env ty
+zonk_pat env (SigPat ty pat)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pat') <- zonkPat env pat
-        ; return (env', SigPatOut pat' ty') }
+        ; return (env', SigPat ty' pat') }
 
-zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
+zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
   = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
         ; (env2, mb_neg') <- case mb_neg of
             Nothing -> return (env1, Nothing)
             Just n  -> second Just <$> zonkSyntaxExpr env1 n
 
         ; lit' <- zonkOverLit env2 lit
-        ; ty' <- zonkTcTypeToType env2 ty
-        ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }
+        ; ty' <- zonkTcTypeToTypeX env2 ty
+        ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
 
-zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
+zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
   = do  { (env1, e1') <- zonkSyntaxExpr env  e1
         ; (env2, e2') <- zonkSyntaxExpr env1 e2
         ; n' <- zonkIdBndr env2 n
         ; lit1' <- zonkOverLit env2 lit1
         ; lit2' <- zonkOverLit env2 lit2
-        ; ty' <- zonkTcTypeToType env2 ty
+        ; ty' <- zonkTcTypeToTypeX env2 ty
         ; return (extendIdZonkEnv1 env2 n',
-                  NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }
+                  NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
 
-zonk_pat env (CoPat co_fn pat ty)
+zonk_pat env (CoPat x co_fn pat ty)
   = do { (env', co_fn') <- zonkCoFn env co_fn
        ; (env'', pat') <- zonkPat env' (noLoc pat)
-       ; ty' <- zonkTcTypeToType env'' ty
-       ; return (env'', CoPat co_fn' (unLoc pat') ty') }
+       ; ty' <- zonkTcTypeToTypeX env'' ty
+       ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
 
 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
 
@@ -1357,9 +1463,10 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]
 zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
 
 zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
-zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
-  = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
-                          , fd_sig_ty = undefined, fd_co = co
+zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
+                                     , fd_fe = spec })
+  = return (ForeignExport { fd_name = zonkLIdOcc env i
+                          , fd_sig_ty = undefined, fd_e_ext = co
                           , fd_fe = spec })
 zonkForeignExport _ for_imp
   = return for_imp     -- Foreign imports don't need zonking
@@ -1368,21 +1475,22 @@ zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
-zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
+zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs)
   = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars
 
-       ; let env_lhs = setZonkType env_inside zonkTvSkolemising
+       ; let env_lhs = setZonkType env_inside SkolemiseFlexi
               -- See Note [Zonking the LHS of a RULE]
 
        ; new_lhs <- zonkLExpr env_lhs    lhs
        ; new_rhs <- zonkLExpr env_inside rhs
 
-       ; return (HsRule name act new_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
+       ; return (HsRule fvs name act new_bndrs new_lhs new_rhs ) }
   where
-   zonk_bndr env (L l (RuleBndr (L loc v)))
+   zonk_bndr env (L l (RuleBndr x (L loc v)))
       = do { (env', v') <- zonk_it env v
-           ; return (env', L l (RuleBndr (L loc v'))) }
+           ; return (env', L l (RuleBndr x (L loc v'))) }
    zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
+   zonk_bndr _ (L _ (XRuleBndr {})) = panic "zonk_bndr XRuleBndr"
 
    zonk_it env v
      | isId v     = do { v' <- zonkIdBndr env v
@@ -1392,29 +1500,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
                     -- DV: used to be return (env,v) but that is plain
                     -- wrong because we may need to go inside the kind
                     -- of v and zonk there!
-
-zonkVects :: ZonkEnv -> [LVectDecl GhcTcId] -> TcM [LVectDecl GhcTc]
-zonkVects env = mapM (wrapLocM (zonkVect env))
-
-zonkVect :: ZonkEnv -> VectDecl GhcTcId -> TcM (VectDecl GhcTc)
-zonkVect env (HsVect s v e)
-  = do { v' <- wrapLocM (zonkIdBndr env) v
-       ; e' <- zonkLExpr env e
-       ; return $ HsVect s v' e'
-       }
-zonkVect env (HsNoVect s v)
-  = do { v' <- wrapLocM (zonkIdBndr env) v
-       ; return $ HsNoVect s v'
-       }
-zonkVect _env (HsVectTypeOut s t rt)
-  = return $ HsVectTypeOut s t rt
-zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
-zonkVect _env (HsVectClassOut c)
-  = return $ HsVectClassOut c
-zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
-zonkVect _env (HsVectInstOut i)
-  = return $ HsVectInstOut i
-zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
+zonkRule _ (XRuleDecl _) = panic "zonkRule"
 
 {-
 ************************************************************************
@@ -1425,39 +1511,76 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
 -}
 
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
-zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v )
-                                    zonkEvVarOcc env v
-zonkEvTerm env (EvCoercion co)    = do { co' <- zonkCoToCo env co
-                                       ; return (EvCoercion co') }
-zonkEvTerm env (EvCast tm co)     = do { tm' <- zonkEvTerm env tm
-                                       ; co' <- zonkCoToCo env co
-                                       ; return (mkEvCast tm' co') }
-zonkEvTerm _   (EvLit l)          = return (EvLit l)
-
-zonkEvTerm env (EvTypeable ty ev) =
-  do { ev' <- zonkEvTypeable env ev
-     ; ty' <- zonkTcTypeToType env ty
-     ; return (EvTypeable ty' ev') }
-zonkEvTerm env (EvCallStack cs)
-  = case cs of
-      EvCsEmpty -> return (EvCallStack cs)
-      EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
-                                ; return (EvCallStack (EvCsPushCall n l tm')) }
-
-zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
-                                       ; return (EvSuperClass d' n) }
-zonkEvTerm env (EvDFunApp df tys tms)
-  = do { tys' <- zonkTcTypeToTypes env tys
-       ; tms' <- mapM (zonkEvTerm env) tms
-       ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
-zonkEvTerm env (EvDelayedError ty msg)
-  = do { ty' <- zonkTcTypeToType env ty
-       ; return (EvDelayedError ty' msg) }
-zonkEvTerm env (EvSelector sel_id tys tms)
-  = do { sel_id' <- zonkIdBndr env sel_id
-       ; tys'    <- zonkTcTypeToTypes env tys
-       ; tms' <- mapM (zonkEvTerm env) tms
-       ; return (EvSelector sel_id' tys' tms') }
+zonkEvTerm env (EvExpr e)
+  = EvExpr <$> zonkCoreExpr env e
+zonkEvTerm env (EvTypeable ty ev)
+  = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
+zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
+                      , et_binds = ev_binds, et_body = body_id })
+  = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+       ; let new_body_id = zonkIdOcc env2 body_id
+       ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
+                       , et_binds = new_ev_binds, et_body = new_body_id }) }
+
+zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
+zonkCoreExpr env (Var v)
+    | isCoVar v
+    = Coercion <$> zonkCoVarOcc env v
+    | otherwise
+    = return (Var $ zonkIdOcc env v)
+zonkCoreExpr _ (Lit l)
+    = return $ Lit l
+zonkCoreExpr env (Coercion co)
+    = Coercion <$> zonkCoToCo env co
+zonkCoreExpr env (Type ty)
+    = Type <$> zonkTcTypeToTypeX env ty
+
+zonkCoreExpr env (Cast e co)
+    = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
+zonkCoreExpr env (Tick t e)
+    = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
+
+zonkCoreExpr env (App e1 e2)
+    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
+zonkCoreExpr env (Lam v e)
+    = do { (env1, v') <- zonkCoreBndrX env v
+         ; Lam v' <$> zonkCoreExpr env1 e }
+zonkCoreExpr env (Let bind e)
+    = do (env1, bind') <- zonkCoreBind env bind
+         Let bind'<$> zonkCoreExpr env1 e
+zonkCoreExpr env (Case scrut b ty alts)
+    = do scrut' <- zonkCoreExpr env scrut
+         ty' <- zonkTcTypeToTypeX env ty
+         b' <- zonkIdBndr env b
+         let env1 = extendIdZonkEnv1 env b'
+         alts' <- mapM (zonkCoreAlt env1) alts
+         return $ Case scrut' b' ty' alts'
+
+zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
+zonkCoreAlt env (dc, bndrs, rhs)
+    = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
+         rhs' <- zonkCoreExpr env1 rhs
+         return $ (dc, bndrs', rhs')
+
+zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
+zonkCoreBind env (NonRec v e)
+    = do v' <- zonkIdBndr env v
+         e' <- zonkCoreExpr env e
+         let env1 = extendIdZonkEnv1 env v'
+         return (env1, NonRec v' e')
+zonkCoreBind env (Rec pairs)
+    = do (env1, pairs') <- fixM go
+         return (env1, Rec pairs')
+  where
+    go ~(_, new_pairs) = do
+         let env1 = extendIdZonkEnvRec env (map fst new_pairs)
+         pairs' <- mapM (zonkCorePair env1) pairs
+         return (env1, pairs')
+
+zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
 
 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
 zonkEvTypeable env (EvTypeableTyCon tycon e)
@@ -1491,6 +1614,7 @@ zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
   = do { bs <- readMutVar ref
        ; zonkEvBinds env (evBindMapBinds bs) }
+zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
 
 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBinds env binds
@@ -1514,39 +1638,13 @@ zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
 
        ; term' <- case getEqPredTys_maybe (idType var') of
            Just (r, ty1, ty2) | ty1 `eqType` ty2
-                  -> return (EvCoercion (mkTcReflCo r ty1))
+                  -> return (evCoercion (mkTcReflCo r ty1))
            _other -> zonkEvTerm env term
 
        ; return (bind { eb_lhs = var', eb_rhs = term' }) }
 
-{-
-************************************************************************
-*                                                                      *
-                         Zonking types
-*                                                                      *
-************************************************************************
-
-Note [Zonking mutable unbound type or kind variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
-arbitrary type. We know if they are unbound even though we don't carry an
-environment, because at the binding site for a variable we bind the mutable
-var to a fresh immutable one.  So the mutable store plays the role of an
-environment.  If we come across a mutable variable that isn't so bound, it
-must be completely free. We zonk the expected kind to make sure we don't get
-some unbound meta variable as the kind.
-
-Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
-type and kind variables. Consider the following datatype:
-
-  data Phantom a = Phantom Int
-
-The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and
-`k` are unbound variables. We want to zonk this to
-(forall (k : Any *). forall (a : Any (Any *)). Int).
-
-Note [Optimise coercion zonking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Optimise coercion zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When optimising evidence binds we may come across situations where
 a coercion looks like
       cv = ReflCo ty
@@ -1560,118 +1658,203 @@ use Refl on the right, ignoring the actual coercion on the RHS.
 This can have a very big effect, because the constraint solver sometimes does go
 to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf Trac #5030)
 
+
+************************************************************************
+*                                                                      *
+                         Zonking types
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Sharing when zonking to Type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem:
+
+    In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
+    (Indirect zty), see Note [Sharing in zonking] in TcMType. But we
+    /can't/ do this when zonking a TcType to a Type (Trac #15552, esp
+    comment:3).  Suppose we have
+
+       alpha -> alpha
+         where
+            alpha is already unified:
+             alpha := T{tc-tycon} Int -> Int
+         and T is knot-tied
+
+    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
+    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
+    Note [Type checking recursive type and class declarations] in
+    TcTyClsDecls.
+
+    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
+    the same path as Note [Sharing in zonking] in TcMType, we'll
+    update alpha to
+       alpha := T{knot-tied-tc} Int -> Int
+
+    But alas, if we encounter alpha for a /second/ time, we end up
+    looking at T{knot-tied-tc} and fall into a black hole. The whole
+    point of zonkTcTypeToType is that it produces a type full of
+    knot-tied tycons, and you must not look at the result!!
+
+    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
+    the same as zonkTcTypeToType. (If we distinguished TcType from
+    Type, this issue would have been a type error!)
+
+Solution: (see Trac #15552 for other variants)
+
+    One possible solution is simply not to do the short-circuiting.
+    That has less sharing, but maybe sharing is rare. And indeed,
+    that turns out to be viable from a perf point of view
+
+    But the code implements something a bit better
+
+    * ZonkEnv contains ze_meta_tv_env, which maps
+          from a MetaTyVar (unificaion variable)
+          to a Type (not a TcType)
+
+    * In zonkTyVarOcc, we check this map to see if we have zonked
+      this variable before. If so, use the previous answer; if not
+      zonk it, and extend the map.
+
+    * The map is of course stateful, held in a TcRef. (That is unlike
+      the treatment of lexically-scoped variables in ze_tv_env and
+      ze_id_env.
+
+    Is the extra work worth it.  Some non-sytematic perf measurements
+    suggest that compiler allocation is reduced overall (by 0.5% or so)
+    but compile time really doesn't change.
 -}
 
 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
-zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
+zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
+                          , ze_tv_env = tv_env
+                          , ze_meta_tv_env = mtv_env_ref }) tv
   | isTcTyVar tv
   = case tcTyVarDetails tv of
-         SkolemTv {}    -> lookup_in_env
-         RuntimeUnk {}  -> lookup_in_env
-         MetaTv { mtv_ref = ref }
-           -> do { cts <- readMutVar ref
-                 ; case cts of
-                      Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
-                                            zonkTcTypeToType env (tyVarKind tv)
-                                  ; zonk_unbound_tyvar (setTyVarKind tv kind) }
-                      Indirect ty -> do { zty <- zonkTcTypeToType env ty
-                                        -- Small optimisation: shortern-out indirect steps
-                                        -- so that the old type may be more easily collected.
-                                        ; writeMutVar ref (Indirect zty)
-                                        ; return zty } }
+      SkolemTv {}    -> lookup_in_tv_env
+      RuntimeUnk {}  -> lookup_in_tv_env
+      MetaTv { mtv_ref = ref }
+        -> do { mtv_env <- readTcRef mtv_env_ref
+                -- See Note [Sharing when zonking to Type]
+              ; case lookupVarEnv mtv_env tv of
+                  Just ty -> return ty
+                  Nothing -> do { mtv_details <- readTcRef ref
+                                ; zonk_meta mtv_env ref mtv_details } }
   | otherwise
-  = lookup_in_env
+  = lookup_in_tv_env
+
   where
-    lookup_in_env    -- Look up in the env just as we do for Ids
+    lookup_in_tv_env    -- Look up in the env just as we do for Ids
       = case lookupVarEnv tv_env tv of
-          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv
+          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
           Just tv' -> return (mkTyVarTy tv')
 
+    zonk_meta mtv_env ref Flexi
+      = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
+           ; let ty = commitFlexi flexi tv kind
+           ; writeMetaTyVarRef tv ref ty  -- Belt and braces
+           ; finish_meta mtv_env (commitFlexi flexi tv kind) }
+
+    zonk_meta mtv_env _ (Indirect ty)
+      = do { zty <- zonkTcTypeToTypeX env ty
+           ; finish_meta mtv_env zty }
+
+    finish_meta mtv_env ty
+      = do { let mtv_env' = extendVarEnv mtv_env tv ty
+           ; writeTcRef mtv_env_ref mtv_env'
+           ; return ty }
+
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> Type
+commitFlexi flexi tv zonked_kind
+  = case flexi of
+      SkolemiseFlexi  -> mkTyVarTy (mkTyVar name zonked_kind)
+
+      DefaultFlexi    | isRuntimeRepTy zonked_kind
+                      -> liftedRepTy
+                      | otherwise
+                      -> anyTypeOfKind zonked_kind
+
+      RuntimeUnkFlexi -> mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)
+                        -- This is where RuntimeUnks are born:
+                        -- otherwise-unconstrained unification variables are
+                        -- turned into RuntimeUnks as they leave the
+                        -- typechecker's monad
+  where
+     name = tyVarName tv
+
 zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
-zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv
+zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
   | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env
   = return $ mkCoVarCo cv'
   | otherwise
-  = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv
-
-zonkCoHole :: ZonkEnv -> CoercionHole
-           -> Role -> Type -> Type  -- these are all redundant with
-                                    -- the details in the hole,
-                                    -- unzonked
-           -> TcM Coercion
-zonkCoHole env h r t1 t2
-  = do { contents <- unpackCoercionHole_maybe h
+  = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
+
+zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
+zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+  = do { contents <- readTcRef ref
        ; case contents of
-           Just co -> do { co <- zonkCoToCo env co
-                         ; checkCoercionHole co h r t1 t2 }
+           Just co -> do { co' <- zonkCoToCo env co
+                         ; checkCoercionHole cv co' }
 
               -- This next case should happen only in the presence of
               -- (undeferred) type errors. Originally, I put in a panic
               -- here, but that caused too many uses of `failIfErrsM`.
-           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h)
+           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
                          ; when debugIsOn $
                            whenNoErrs $
                            MASSERT2( False
                                    , text "Type-correct unfilled coercion hole"
-                                     <+> ppr h )
-                         ; t1 <- zonkTcTypeToType env t1
-                         ; t2 <- zonkTcTypeToType env t2
-                         ; return $ mkHoleCo h r t1 t2 } }
+                                     <+> ppr hole )
+                         ; cv' <- zonkCoVar cv
+                         ; return $ mkHoleCo (hole { ch_co_var = cv' }) } }
 
 zonk_tycomapper :: TyCoMapper ZonkEnv TcM
 zonk_tycomapper = TyCoMapper
   { tcm_smart = True   -- Establish type invariants
-                       -- See Note [Type-checking inside the knot] in TcHsType
   , tcm_tyvar = zonkTyVarOcc
   , tcm_covar = zonkCoVarOcc
   , tcm_hole  = zonkCoHole
-  , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv }
+  , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
+  , tcm_tycon = zonkTcTyConToTyCon }
+
+-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
+zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
+zonkTcTyConToTyCon tc
+  | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
+                      ; case thing of
+                          ATyCon real_tc -> return real_tc
+                          _              -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
+  | otherwise    = return tc -- it's already zonked
 
 -- Confused by zonking? See Note [What is zonking?] in TcMType.
-zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
-zonkTcTypeToType = mapType zonk_tycomapper
+zonkTcTypeToType :: TcType -> TcM Type
+zonkTcTypeToType = initZonkEnv zonkTcTypeToTypeX
+
+zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypeToTypeX = mapType zonk_tycomapper
+
+zonkTcTypesToTypes :: [TcType] -> TcM [Type]
+zonkTcTypesToTypes = initZonkEnv zonkTcTypesToTypesX
 
-zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
-zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
+zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
+zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys
 
 zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
 zonkCoToCo = mapCoercion zonk_tycomapper
 
-zonkSigType :: TcType -> TcM Type
--- Zonk the type obtained from a user type signature
--- We want to turn any quantified (forall'd) variables into TyVars
--- but we may find some free TcTyVars, and we want to leave them
--- completely alone.  They may even have unification variables inside
--- e.g.  f (x::a) = ...(e :: a -> a)....
--- The type sig for 'e' mentions a free 'a' which will be a
--- unification SigTv variable.
-zonkSigType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_tv)
+zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
+zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
+  = do { ty' <- zonkTcTypeToTypeX ze ty
+       ; gdm_spec' <- zonk_gdm gdm_spec
+       ; return (name, ty', gdm_spec') }
   where
-    zonk_unbound_tv :: UnboundTyVarZonker
-    zonk_unbound_tv tv = return (mkTyVarTy tv)
-
-zonkTvSkolemising :: UnboundTyVarZonker
--- This variant is used for the LHS of rules
--- See Note [Zonking the LHS of a RULE].
-zonkTvSkolemising tv
-  = do { let tv' = mkTyVar (tyVarName tv) (tyVarKind tv)
-                  -- NB: the kind of tv is already zonked
-             ty = mkTyVarTy tv'
-                  -- Make a proper TyVar (remember we
-                  -- are now done with type checking)
-       ; writeMetaTyVar tv ty
-       ; return ty }
-
-zonkTypeZapping :: UnboundTyVarZonker
--- This variant is used for everything except the LHS of rules
--- It zaps unbound type variables to Any, except for RuntimeRep
--- vars which it zonks to LiftedRep
--- Works on both types and kinds
-zonkTypeZapping tv
-  = do { let ty | isRuntimeRepVar tv = liftedRepTy
-                | otherwise          = anyTypeOfKind (tyVarKind tv)
-       ; writeMetaTyVar tv ty
-       ; return ty }
+    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
+             -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
+    zonk_gdm Nothing = return Nothing
+    zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
+    zonk_gdm (Just (GenericDM (loc, ty)))
+      = do { ty' <- zonkTcTypeToTypeX ze ty
+           ; return (Just (GenericDM (loc, ty'))) }
 
 ---------------------------------------
 {- Note [Zonking the LHS of a RULE]
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 045a0a1983..a9d6d46344 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -6,6 +6,7 @@
 -}
 
 {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module TcHsType (
         -- Type signatures
@@ -15,29 +16,41 @@ module TcHsType (
         funsSigCtxt, addSigCtxt, pprSigCtxt,
 
         tcHsClsInstType,
-        tcHsDeriv, tcHsVectInst,
+        tcHsDeriv, tcDerivStrategy,
         tcHsTypeApp,
         UserTypeCtxt(..),
-        tcImplicitTKBndrs, tcImplicitTKBndrsType, tcExplicitTKBndrs,
+        tcImplicitTKBndrs, tcImplicitQTKBndrs,
+        tcExplicitTKBndrs,
+        kcExplicitTKBndrs, kcImplicitTKBndrs,
 
                 -- Type checking type and class decls
         kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,
         tcDataKindSig,
 
+          -- tyvars
+        scopeTyVars, scopeTyVars2,
+
         -- Kind-checking types
         -- No kind generalisation, no checkValidType
+        kcLHsQTyVars,
         tcWildCardBinders,
-        kcHsTyVarBndrs,
         tcHsLiftedType,   tcHsOpenType,
         tcHsLiftedTypeNC, tcHsOpenTypeNC,
-        tcLHsType, tcCheckLHsType,
-        tcHsContext, tcLHsPredType, tcInferApps, tcInferArgs,
+        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
+        failIfEmitsConstraints,
         solveEqualities, -- useful re-export
 
-        kindGeneralize,
+        typeLevelMode, kindLevelMode,
+
+        kindGeneralize, checkExpectedKindX, instantiateTyUntilN,
+        reportFloatingKvs,
 
         -- Sort-checking kinds
-        tcLHsKindSig,
+        tcLHsKindSig, badKindSig,
+
+        -- Zonking and promoting
+        zonkPromoteType,
 
         -- Pattern type signatures
         tcHsPatSigType, tcPatSig, funAppCtxt
@@ -45,6 +58,8 @@ module TcHsType (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import TcRnMonad
 import TcEvidence
@@ -53,12 +68,14 @@ import TcMType
 import TcValidity
 import TcUnify
 import TcIface
-import TcSimplify ( solveEqualities )
+import TcSimplify
+import TcHsSyn
+import TcErrors ( reportAllUnsolved )
 import TcType
-import TcHsSyn( zonkSigType )
-import Inst   ( tcInstBinders, tcInstBinder )
+import Inst   ( tcInstTyBinders, tcInstTyBinder )
+import TyCoRep( TyCoBinder(..), TyBinder )  -- Used in tcDataKindSig
 import Type
-import Kind
+import Coercion
 import RdrName( lookupLocalRdrOcc )
 import Var
 import VarSet
@@ -67,7 +84,6 @@ import ConLike
 import DataCon
 import Class
 import Name
-import NameEnv
 import NameSet
 import VarEnv
 import TysWiredIn
@@ -84,7 +100,7 @@ import PrelNames hiding ( wildCardName )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Maybes
-import Data.List ( partition, zipWith4 )
+import Data.List ( find, mapAccumR )
 import Control.Monad
 
 {-
@@ -99,13 +115,6 @@ to do this on un-desugared types. Luckily, desugared types are close enough
 to HsTypes to make the error messages sane.
 
 During type-checking, we perform as little validity checking as possible.
-This is because some type-checking is done in a mutually-recursive knot, and
-if we look too closely at the tycons, we'll loop. This is why we always must
-use mkNakedTyConApp and mkNakedAppTys, etc., which never look at a tycon.
-The mkNamed... functions don't uphold Type invariants, but zonkTcTypeToType
-will repair this for us. Note that zonkTcType *is* safe within a knot, and
-can be done repeatedly with no ill effect: it just squeezes out metavariables.
-
 Generally, after type-checking, you will want to do validity checking, say
 with TcValidity.checkValidType.
 
@@ -124,20 +133,12 @@ but not all:
 - Similarly, also a GHC extension, we look through synonyms before complaining
   about the form of a class or instance declaration
 
-- Ambiguity checks involve functional dependencies, and it's easier to wait
-  until knots have been resolved before poking into them
+- Ambiguity checks involve functional dependencies
 
 Also, in a mutually recursive group of types, we can't look at the TyCon until we've
 finished building the loop.  So to keep things simple, we postpone most validity
 checking until step (3).
 
-Knot tying
-~~~~~~~~~~
-During step (1) we might fault in a TyCon defined in another module, and it might
-(via a loop) refer back to a TyCon defined in this module. So when we tie a big
-knot around type declarations with ARecThing, so that the fault-in code can get
-the TyCon being defined.
-
 %************************************************************************
 %*                                                                      *
               Check types AND do validity checking
@@ -177,26 +178,28 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
 -- already checked this, so we can simply ignore it.
 tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
 
-kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
-kcHsSigType names (HsIB { hsib_body = hs_ty
-                        , hsib_vars = sig_vars })
+kcHsSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
+kcHsSigType skol_info names (HsIB { hsib_body = hs_ty
+                                  , hsib_ext = sig_vars })
   = addSigCtxt (funsSigCtxt names) hs_ty $
     discardResult $
-    tcImplicitTKBndrsType sig_vars $
+    tcImplicitTKBndrs skol_info sig_vars $
     tc_lhs_type typeLevelMode hs_ty liftedTypeKind
+kcHsSigType  _ _ (XHsImplicitBndrs _) = panic "kcHsSigType"
 
-tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type
--- Does not do validity checking; this must be done outside
--- the recursive class declaration "knot"
-tcClassSigType names sig_ty
+tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
+-- Does not do validity checking
+tcClassSigType skol_info names sig_ty
   = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
-    tc_hs_sig_type_and_gen sig_ty liftedTypeKind
+    tc_hs_sig_type_and_gen skol_info sig_ty liftedTypeKind
 
 tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
 -- Does validity checking
+-- See Note [Recipe for checking a signature]
 tcHsSigType ctxt sig_ty
   = addSigCtxt ctxt (hsSigType sig_ty) $
-    do { kind <- case expectedKindInCtxt ctxt of
+    do { traceTc "tcHsSigType {" (ppr sig_ty)
+       ; kind <- case expectedKindInCtxt ctxt of
                     AnythingKind -> newMetaKindVar
                     TheKind k    -> return k
                     OpenKind     -> newOpenTypeKind
@@ -204,97 +207,148 @@ tcHsSigType ctxt sig_ty
               -- of kind * in a Template Haskell quote eg [t| Maybe |]
 
           -- Generalise here: see Note [Kind generalisation]
-       ; do_kind_gen <- decideKindGeneralisationPlan sig_ty
-       ; ty <- if do_kind_gen
-               then tc_hs_sig_type_and_gen sig_ty kind
-               else tc_hs_sig_type         sig_ty kind >>= zonkTcType
+       ; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind
+       ; ty <- zonkTcType ty
 
        ; checkValidType ctxt ty
+       ; traceTc "end tcHsSigType }" (ppr ty)
        ; return ty }
+  where
+    skol_info = SigTypeSkol ctxt
 
-tc_hs_sig_type_and_gen :: LHsSigType GhcRn -> Kind -> TcM Type
+tc_hs_sig_type_and_gen :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type
 -- Kind-checks/desugars an 'LHsSigType',
 --   solve equalities,
 --   and then kind-generalizes.
 -- This will never emit constraints, as it uses solveEqualities interally.
--- No validity checking, but it does zonk en route to generalization
-tc_hs_sig_type_and_gen hs_ty kind
-  = do { ty <- solveEqualities $
-               tc_hs_sig_type hs_ty kind
-         -- NB the call to solveEqualities, which unifies all those
-         --    kind variables floating about, immediately prior to
-         --    kind generalisation
-       ; kindGeneralizeType ty }
-
-tc_hs_sig_type :: LHsSigType GhcRn -> Kind -> TcM Type
--- Kind-check/desugar a 'LHsSigType', but does not solve
--- the equalities that arise from doing so; instead it may
--- emit kind-equality constraints into the monad
--- No zonking or validity checking
-tc_hs_sig_type (HsIB { hsib_vars = sig_vars
-                     , hsib_body = hs_ty }) kind
-  = do { (tkvs, ty) <- tcImplicitTKBndrsType sig_vars $
-                       tc_lhs_type typeLevelMode hs_ty kind
-       ; return (mkSpecForAllTys tkvs ty) }
+-- No validity checking or zonking
+tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext = sig_vars
+                                       , hsib_body = hs_ty }) kind
+  = do { ((tkvs, ty), wanted) <- captureConstraints $
+                                 tcImplicitTKBndrs skol_info sig_vars $
+                                 tc_lhs_type typeLevelMode hs_ty kind
+         -- Any remaining variables (unsolved in the solveLocalEqualities
+         -- in the tcImplicitTKBndrs) should be in the global tyvars,
+         -- and therefore won't be quantified over
+
+       ; let ty1 = mkSpecForAllTys tkvs ty
+       ; kvs <- kindGeneralizeLocal wanted ty1
+       ; emitConstraints wanted -- we still need to solve these
+       ; return (mkInvForAllTys kvs ty1) }
+
+tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
 
 -----------------
-tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
 -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
 -- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
 -- E.g.    class C (a::*) (b::k->k)
 --         data T a b = ... deriving( C Int )
 --    returns ([k], C, [k, Int], [k->k])
+-- Return values are fully zonked
 tcHsDeriv hs_ty
   = do { cls_kind <- newMetaKindVar
                     -- always safe to kind-generalize, because there
                     -- can be no covars in an outer scope
        ; ty <- checkNoErrs $
                  -- avoid redundant error report with "illegal deriving", below
-               tc_hs_sig_type_and_gen hs_ty cls_kind
-       ; cls_kind <- zonkTcType cls_kind
+               tc_hs_sig_type_and_gen (SigTypeSkol DerivClauseCtxt) hs_ty cls_kind
+       ; cls_kind <- zonkTcTypeToType cls_kind
+       ; ty <- zonkTcTypeToType ty
        ; let (tvs, pred) = splitForAllTys ty
        ; let (args, _) = splitFunTys cls_kind
        ; case getClassPredTys_maybe pred of
-           Just (cls, tys) -> return (tvs, cls, tys, args)
+           Just (cls, tys) -> return (tvs, (cls, tys, args))
            Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
 
+-- | Typecheck something within the context of a deriving strategy.
+-- This is of particular importance when the deriving strategy is @via@.
+-- For instance:
+--
+-- @
+-- deriving via (S a) instance C (T a)
+-- @
+--
+-- We need to typecheck @S a@, and moreover, we need to extend the tyvar
+-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified
+-- the type variable @a@.
+tcDerivStrategy
+  :: forall a.
+     UserTypeCtxt
+  -> Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
+  -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the
+                      -- deriving strategy, which might quantify some type
+                      -- variables of its own.
+  -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
+     -- ^ The typechecked deriving strategy, all quantified tyvars, and
+     -- the payload of the typechecked thing.
+tcDerivStrategy user_ctxt mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds
+                    pure (Just ds', tvs, thing)
+  where
+    tc_deriv_strategy :: DerivStrategy GhcRn
+                      -> TcM (DerivStrategy GhcTc, [TyVar], a)
+    tc_deriv_strategy StockStrategy    = boring_case StockStrategy
+    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
+    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy
+    tc_deriv_strategy (ViaStrategy ty) = do
+      cls_kind <- newMetaKindVar
+      ty' <- checkNoErrs $
+             tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) ty cls_kind
+      ty' <- zonkTcTypeToType ty'
+      let (via_tvs, via_pred) = splitForAllTys ty'
+      tcExtendTyVarEnv via_tvs $ do
+        (thing_tvs, thing) <- thing_inside
+        pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)
+
+    boring_case :: mds -> TcM (mds, [TyVar], a)
+    boring_case mds = do
+      (thing_tvs, thing) <- thing_inside
+      pure (mds, thing_tvs, thing)
+
 tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
                 -> LHsSigType GhcRn
                 -> TcM ([TyVar], ThetaType, Class, [Type])
 -- Like tcHsSigType, but for a class instance declaration
 tcHsClsInstType user_ctxt hs_inst_ty
   = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
-    do { inst_ty <- tc_hs_sig_type_and_gen hs_inst_ty constraintKind
+    {- We want to fail here if the tc_hs_sig_type_and_gen emits constraints.
+       First off, we know we'll never solve the constraints, as classes are
+       always at top level, and their constraints do not inform the kind checking
+       of method types. So failing isn't wrong. Yet, the reason we do it is
+       to avoid the validity checker from seeing unsolved coercion holes in
+       types. Much better just to report the kind error directly. -}
+    do { inst_ty <- failIfEmitsConstraints $
+                    tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) hs_inst_ty constraintKind
+       ; inst_ty <- zonkTcTypeToType inst_ty
        ; checkValidInstance user_ctxt hs_inst_ty inst_ty }
 
--- Used for 'VECTORISE [SCALAR] instance' declarations
-tcHsVectInst :: LHsSigType GhcRn -> TcM (Class, [Type])
-tcHsVectInst ty
-  | Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty)
-    -- Ignoring the binders looks pretty dodgy to me
-  = do { (cls, cls_kind) <- tcClass cls_name
-       ; (applied_class, _res_kind)
-           <- tcInferApps typeLevelMode cls_name (mkClassPred cls []) cls_kind tys
-       ; case tcSplitTyConApp_maybe applied_class of
-           Just (_tc, args) -> ASSERT( _tc == classTyCon cls )
-                               return (cls, args)
-           _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) }
-  | otherwise
-  = failWithTc $ text "Malformed instance type"
-
 ----------------------------------------------
 -- | Type-check a visible type application
 tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
+-- See Note [Recipe for checking a signature] in TcHsType
 tcHsTypeApp wc_ty kind
-  | HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty
-  = do { ty <- tcWildCardBindersX newWildTyVar sig_wcs $ \ _ ->
+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty
+  = do { ty <- solveLocalEqualities $
+               -- We are looking at a user-written type, very like a
+               -- signature so we want to solve its equalities right now
+               tcWildCardBinders sig_wcs $ \ _ ->
                tcCheckLHsType hs_ty kind
-       ; ty <- zonkTcType ty
+       -- We must promote here. Ex:
+       --   f :: forall a. a
+       --   g = f @(forall b. Proxy b -> ()) @Int ...
+       -- After when processing the @Int, we'll have to check its kind
+       -- against the as-yet-unknown kind of b. This check causes an assertion
+       -- failure if we don't promote.
+       ; ty <- zonkPromoteType ty
        ; checkValidType TypeAppCtxt ty
        ; return ty }
         -- NB: we don't call emitWildcardHoleConstraints here, because
         -- we want any holes in visible type applications to be used
         -- without fuss. No errors, warnings, extensions, etc.
+tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"
 
 {-
 ************************************************************************
@@ -319,7 +373,7 @@ tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind
 tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind
 
 -- Like tcHsType, but takes an expected kind
-tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM Type
+tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType
 tcCheckLHsType hs_ty exp_kind
   = addTypeCtxt hs_ty $
     tc_lhs_type typeLevelMode hs_ty exp_kind
@@ -328,47 +382,14 @@ tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)
 -- Called from outside: set the context
 tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)
 
----------------------------
--- | Should we generalise the kind of this type signature?
--- We *should* generalise if the type is closed
--- or if NoMonoLocalBinds is set. Otherwise, nope.
--- See Note [Kind generalisation plan]
-decideKindGeneralisationPlan :: LHsSigType GhcRn -> TcM Bool
-decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed })
-  = do { mono_locals <- xoptM LangExt.MonoLocalBinds
-       ; let should_gen = not mono_locals || closed
-       ; traceTc "decideKindGeneralisationPlan"
-           (ppr sig_ty $$ text "should gen?" <+> ppr should_gen)
-       ; return should_gen }
-
-{- Note [Kind generalisation plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When should we do kind-generalisation for user-written type signature?
-Answer: we use the same rule as for value bindings:
-
- * We always kind-generalise if the type signature is closed
- * Additionally, we attempt to generalise if we have NoMonoLocalBinds
-
-Trac #13337 shows the problem if we kind-generalise an open type (i.e.
-one that mentions in-scope tpe variable
-  foo :: forall k (a :: k) proxy. (Typeable k, Typeable a)
-      => proxy a -> String
-  foo _ = case eqT :: Maybe (k :~: Type) of
-            Nothing   -> ...
-            Just Refl -> case eqT :: Maybe (a :~: Int) of ...
-
-In the expression type sig on the last line, we have (a :: k)
-but (Int :: Type).  Since (:~:) is kind-homogeneous, this requires
-k ~ *, which is true in the Refl branch of the outer case.
-
-That equality will be solved if we allow it to float out to the
-implication constraint for the Refl match, bnot not if we aggressively
-attempt to solve all equalities the moment they occur; that is, when
-checking (Maybe (a :~: Int)).   (NB: solveEqualities fails unless it
-solves all the kind equalities, which is the right thing at top level.)
-
-So here the right thing is simply not to do kind generalisation!
+-- Like tcLHsType, but use it in a context where type synonyms and type families
+-- do not need to be saturated, like in a GHCi :kind call
+tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
+tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty)
+  where
+    mode = allowUnsaturated typeLevelMode
 
+{-
 ************************************************************************
 *                                                                      *
       Type-checking modes
@@ -387,15 +408,21 @@ concern things that the renamer can't handle.
 -- differentiates only between types and kinds, but this will likely
 -- grow, at least to include the distinction between patterns and
 -- not-patterns.
-newtype TcTyMode
-  = TcTyMode { mode_level :: TypeOrKind  -- True <=> type, False <=> kind
+data TcTyMode
+  = TcTyMode { mode_level :: TypeOrKind
+             , mode_unsat :: Bool        -- True <=> allow unsaturated type families
              }
+ -- The mode_unsat field is solely so that type families/synonyms can be unsaturated
+ -- in GHCi :kind calls
 
 typeLevelMode :: TcTyMode
-typeLevelMode = TcTyMode { mode_level = TypeLevel }
+typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_unsat = False }
 
 kindLevelMode :: TcTyMode
-kindLevelMode = TcTyMode { mode_level = KindLevel }
+kindLevelMode = TcTyMode { mode_level = KindLevel, mode_unsat = False }
+
+allowUnsaturated :: TcTyMode -> TcTyMode
+allowUnsaturated mode = mode { mode_unsat = True }
 
 -- switch to kind level
 kindLevel :: TcTyMode -> TcTyMode
@@ -422,7 +449,7 @@ metavariable.
 In types, however, we're not so lucky, because *we cannot re-generalize*!
 There is no lambda. So, we must be careful only to instantiate at the last
 possible moment, when we're sure we're never going to want the lost polymorphism
-again. This is done in calls to tcInstBinders.
+again. This is done in calls to tcInstTyBinders.
 
 To implement this behavior, we use bidirectional type checking, where we
 explicitly think about whether we know the kind of the type we're checking
@@ -448,6 +475,38 @@ are mutually recursive, so that either one can work for any type former.
 But, we want to make sure that our pattern-matches are complete. So,
 we have a bunch of repetitive code just so that we get warnings if we're
 missing any patterns.
+
+Note [The tcType invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(IT1) If    tc_ty = tc_hs_type hs_ty exp_kind
+      then  typeKind tc_ty = exp_kind
+without any zonking needed.  The reason for this is that in
+tcInferApps we see (F ty), and we kind-check 'ty' with an
+expected-kind coming from F.  Then, to make the resulting application
+well kinded --- see Note [The well-kinded type invariant] in TcType ---
+we need the kind-checked 'ty' to have exactly the kind that F expects,
+with no funny zonking nonsense in between.
+
+The tcType invariant also applies to checkExpectedKind:
+
+(IT2) if
+        (tc_ty, _, _) = checkExpectedKind ty act_ki exp_ki
+      then
+        typeKind tc_ty = exp_ki
+
+These other invariants are all necessary, too, as these functions
+are used within tc_hs_type:
+
+(IT3) If (ty, ki) <- tc_infer_hs_type ..., then typeKind ty == ki.
+
+(IT4) If (ty, ki) <- tc_infer_hs_type ..., then zonk ki == ki.
+      (In other words, the result kind of tc_infer_hs_type is zonked.)
+
+(IT5) If (ty, ki) <- tcTyVar ..., then typeKind ty == ki.
+
+(IT6) If (ty, ki) <- tcTyVar ..., then zonk ki == ki.
+      (In other words, the result kind of tcTyVar is zonked.)
+
 -}
 
 ------------------------------------------
@@ -463,32 +522,44 @@ tc_infer_lhs_type mode (L span ty)
 -- | Infer the kind of a type and desugar. This is the "up" type-checker,
 -- as described in Note [Bidirectional type checking]
 tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
-tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv
-tc_infer_hs_type mode (HsAppTy ty1 ty2)
-  = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
-       ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty
-       ; fun_kind' <- zonkTcType fun_kind
-       ; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys }
-tc_infer_hs_type mode (HsParTy t)     = tc_infer_lhs_type mode t
-tc_infer_hs_type mode (HsOpTy lhs (L _ op) rhs)
-  | not (op `hasKey` funTyConKey)
-  = do { (op', op_kind) <- tcTyVar mode op
-       ; op_kind' <- zonkTcType op_kind
-       ; tcInferApps mode op op' op_kind' [lhs, rhs] }
-tc_infer_hs_type mode (HsKindSig ty sig)
-  = do { sig' <- tc_lhs_kind (kindLevel mode) sig
+tc_infer_hs_type mode (HsParTy _ t)          = tc_infer_lhs_type mode t
+tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv
+
+tc_infer_hs_type mode (HsAppTy _ ty1 ty2)
+  = do { let (hs_fun_ty, hs_arg_tys) = splitHsAppTys ty1 [ty2]
+       ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty
+           -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked
+       ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_arg_tys }
+
+tc_infer_hs_type mode (HsOpTy _ lhs lhs_op@(L _ hs_op) rhs)
+  | not (hs_op `hasKey` funTyConKey)
+  = do { (op, op_kind) <- tcTyVar mode hs_op
+       ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted lhs_op) op op_kind
+                       [lhs, rhs] }
+
+tc_infer_hs_type mode (HsKindSig _ ty sig)
+  = do { sig' <- tcLHsKindSig KindSigCtxt sig
+                 -- We must typecheck the kind signature, and solve all
+                 -- its equalities etc; from this point on we may do
+                 -- things like instantiate its foralls, so it needs
+                 -- to be fully determined (Trac #14904)
+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')
        ; ty' <- tc_lhs_type mode ty sig'
        ; return (ty', sig') }
+
 -- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate
 -- the splice location to the typechecker. Here we skip over it in order to have
 -- the same kind inferred for a given expression whether it was produced from
 -- splices or not.
 --
 -- See Note [Delaying modFinalizers in untyped splices].
-tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _)
+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))
   = tc_infer_hs_type mode ty
-tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty
-tc_infer_hs_type _    (HsCoreTy ty)  = return (ty, typeKind ty)
+
+tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
+tc_infer_hs_type _    (XHsType (NHsCoreTy ty))
+  = do { ty <- zonkTcType ty  -- (IT3) and (IT4) of Note [The tcType invariant]
+       ; return (ty, typeKind ty) }
 tc_infer_hs_type mode other_ty
   = do { kv <- newMetaKindVar
        ; ty' <- tc_hs_type mode other_ty kv
@@ -498,8 +569,7 @@ tc_infer_hs_type mode other_ty
 tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
 tc_lhs_type mode (L span ty) exp_kind
   = setSrcSpan span $
-    do { ty' <- tc_hs_type mode ty exp_kind
-       ; return ty' }
+    tc_hs_type mode ty exp_kind
 
 ------------------------------------------
 tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind
@@ -510,23 +580,34 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
        ; res_k <- newOpenTypeKind
        ; ty1' <- tc_lhs_type mode ty1 arg_k
        ; ty2' <- tc_lhs_type mode ty2 res_k
-       ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
   KindLevel ->  -- no representation polymorphism in kinds. yet.
     do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
        ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
-       ; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
 
 ------------------------------------------
--- See also Note [Bidirectional type checking]
 tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
-tc_hs_type mode (HsParTy ty)   exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type _ ty@(HsBangTy {}) _
+-- See Note [The tcType invariant]
+-- See Note [Bidirectional type checking]
+
+tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type _ ty@(HsBangTy _ bang _) _
     -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
     -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-    -- bangs are invalid, so fail. (#7210)
-    = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty)
-tc_hs_type _ ty@(HsRecTy _)      _
+    -- bangs are invalid, so fail. (#7210, #14761)
+    = do { let bangError err = failWith $
+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
+                 text err <+> text "annotation cannot appear nested inside a type"
+         ; case bang of
+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"
+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"
+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"
+             HsSrcBang _ _ _                   -> bangError "strictness" }
+tc_hs_type _ ty@(HsRecTy {})      _
       -- Record types (which only show up temporarily in constructor
       -- signatures) should have been removed by now
     = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
@@ -536,9 +617,7 @@ tc_hs_type _ ty@(HsRecTy _)      _
 -- while capturing the local environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices].
-tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))
-                            _
-                )
+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))
            exp_kind
   = do addModFinalizersWithLclEnv mod_finalizers
        tc_hs_type mode ty exp_kind
@@ -548,23 +627,21 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
   = failWithTc (text "Unexpected type splice:" <+> ppr ty)
 
 ---------- Functions and applications
-tc_hs_type mode (HsFunTy ty1 ty2) exp_kind
+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind
   = tc_fun_type mode ty1 ty2 exp_kind
 
-tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind
+tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
   | op `hasKey` funTyConKey
   = tc_fun_type mode ty1 ty2 exp_kind
 
 --------- Foralls
-tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
-  = fmap fst $
-    tcExplicitTKBndrs hs_tvs $ \ tvs' ->
+tc_hs_type mode forall@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
+  = do { (tvs', ty') <- tcExplicitTKBndrs (ForAllSkol (ppr forall)) hs_tvs $
+                        tc_lhs_type mode ty exp_kind
     -- Do not kind-generalise here!  See Note [Kind generalisation]
     -- Why exp_kind?  See Note [Body kind of HsForAllTy]
-    do { ty' <- tc_lhs_type mode ty exp_kind
-       ; let bound_vars = allBoundVariables ty'
-             bndrs      = mkTyVarBinders Specified tvs'
-       ; return (mkForAllTys bndrs ty', bound_vars) }
+       ; let bndrs      = mkTyVarBinders Specified tvs'
+       ; return (mkForAllTys bndrs ty') }
 
 tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
   | null (unLoc ctxt)
@@ -574,35 +651,29 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
   = do { ctxt' <- tc_hs_context mode ctxt
 
          -- See Note [Body kind of a HsQualTy]
-       ; ty' <- if isConstraintKind exp_kind
+       ; ty' <- if tcIsConstraintKind exp_kind
                 then tc_lhs_type mode ty constraintKind
                 else do { ek <- newOpenTypeKind
                                 -- The body kind (result of the function)
-                                -- can be * or #, hence newOpenTypeKind
-                        ; ty <- tc_lhs_type mode ty ek
-                        ; checkExpectedKind ty liftedTypeKind exp_kind }
+                                -- can be TYPE r, for any r, hence newOpenTypeKind
+                        ; ty' <- tc_lhs_type mode ty ek
+                        ; checkExpectedKind (unLoc ty) ty' liftedTypeKind exp_kind }
 
        ; return (mkPhiTy ctxt' ty') }
 
 --------- Lists, arrays, and tuples
-tc_hs_type mode (HsListTy elt_ty) exp_kind
+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
   = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
        ; checkWiredInTyCon listTyCon
-       ; checkExpectedKind (mkListTy tau_ty) liftedTypeKind exp_kind }
-
-tc_hs_type mode (HsPArrTy elt_ty) exp_kind
-  = do { MASSERT( isTypeLevel (mode_level mode) )
-       ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
-       ; checkWiredInTyCon parrTyCon
-       ; checkExpectedKind (mkPArrTy tau_ty) liftedTypeKind exp_kind }
+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
 
 -- See Note [Distinguishing tuple kinds] in HsTypes
 -- See Note [Inferring tuple kinds]
-tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
      -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
   | Just tup_sort <- tupKindSort_maybe exp_kind
   = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
-    tc_tuple mode tup_sort hs_tys exp_kind
+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind
   | otherwise
   = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
        ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
@@ -620,14 +691,14 @@ tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
          -- In the [] case, it's not clear what the kind is, so guess *
 
        ; tys' <- sequence [ setSrcSpan loc $
-                            checkExpectedKind ty kind arg_kind
-                          | ((L loc _),ty,kind) <- zip3 hs_tys tys kinds ]
+                            checkExpectedKind hs_ty ty kind arg_kind
+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
 
-       ; finish_tuple tup_sort tys' (map (const arg_kind) tys') exp_kind }
+       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
 
 
-tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind
-  = tc_tuple mode tup_sort tys exp_kind
+tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
+  = tc_tuple rn_ty mode tup_sort tys exp_kind
   where
     tup_sort = case hs_tup_sort of  -- Fourth case dealt with above
                   HsUnboxedTuple    -> UnboxedTuple
@@ -635,28 +706,29 @@ tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind
                   HsConstraintTuple -> ConstraintTuple
                   _                 -> panic "tc_hs_type HsTupleTy"
 
-tc_hs_type mode (HsSumTy hs_tys) exp_kind
+tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
   = do { let arity = length hs_tys
        ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
        ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
-       ; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds
+       ; let arg_reps = map getRuntimeRepFromKind arg_kinds
              arg_tys  = arg_reps ++ tau_tys
-       ; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys)
+       ; checkExpectedKind rn_ty
+                           (mkTyConApp (sumTyCon arity) arg_tys)
                            (unboxedSumKind arg_reps)
                            exp_kind
        }
 
 --------- Promoted lists and tuples
-tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind
+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
   = do { tks <- mapM (tc_infer_lhs_type mode) tys
-       ; (taus', kind) <- unifyKinds tks
+       ; (taus', kind) <- unifyKinds tys tks
        ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
-       ; checkExpectedKind ty (mkListTy kind) exp_kind }
+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }
   where
     mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
     mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]
 
-tc_hs_type mode (HsExplicitTupleTy _ tys) exp_kind
+tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
   -- using newMetaKindVar means that we force instantiations of any polykinded
   -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
   = do { ks   <- replicateM arity newMetaKindVar
@@ -664,35 +736,32 @@ tc_hs_type mode (HsExplicitTupleTy _ tys) exp_kind
        ; let kind_con   = tupleTyCon           Boxed arity
              ty_con     = promotedTupleDataCon Boxed arity
              tup_k      = mkTyConApp kind_con ks
-       ; checkExpectedKind (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
   where
     arity = length tys
 
 --------- Constraint types
-tc_hs_type mode (HsIParamTy (L _ n) ty) exp_kind
+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
   = do { MASSERT( isTypeLevel (mode_level mode) )
        ; ty' <- tc_lhs_type mode ty liftedTypeKind
        ; let n' = mkStrLitTy $ hsIPNameFS n
        ; ipClass <- tcLookupClass ipClassName
-       ; checkExpectedKind (mkClassPred ipClass [n',ty'])
+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
            constraintKind exp_kind }
 
-tc_hs_type mode (HsEqTy ty1 ty2) exp_kind
-  = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1
-       ; (ty2', kind2) <- tc_infer_lhs_type mode ty2
-       ; ty2'' <- checkExpectedKind ty2' kind2 kind1
-       ; eq_tc <- tcLookupTyCon eqTyConName
-       ; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2'']
-       ; checkExpectedKind ty' constraintKind exp_kind }
+tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind
+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to
+  -- handle it in 'coreView' and 'tcView'.
+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind
 
 --------- Literals
-tc_hs_type _ (HsTyLit (HsNumTy _ n)) exp_kind
+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
   = do { checkWiredInTyCon typeNatKindCon
-       ; checkExpectedKind (mkNumLitTy n) typeNatKind exp_kind }
+       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }
 
-tc_hs_type _ (HsTyLit (HsStrTy _ s)) exp_kind
+tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
   = do { checkWiredInTyCon typeSymbolKindCon
-       ; checkExpectedKind (mkStrLitTy s) typeSymbolKind exp_kind }
+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
 
 --------- Potentially kind-polymorphic types: call the "up" checker
 -- See Note [Future-proofing the type checker]
@@ -700,57 +769,56 @@ tc_hs_type mode ty@(HsTyVar {})   ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsAppTy {})   ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsOpTy {})    ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsCoreTy {})  ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
 
 tc_hs_type _ (HsWildCardTy wc) exp_kind
-  = do { wc_tv <- tcWildCardOcc wc exp_kind
-       ; return (mkTyVarTy wc_tv) }
-
--- disposed of by renamer
-tc_hs_type _ ty@(HsAppsTy {}) _
-  = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty)
+  = do { wc_ty <- tcWildCardOcc wc exp_kind
+       ; return (mkNakedCastTy wc_ty (mkTcNomReflCo exp_kind))
+         -- Take care here! Even though the coercion is Refl,
+         -- we still need it to establish Note [The tcType invariant]
+       }
 
-tcWildCardOcc :: HsWildCardInfo GhcRn -> Kind -> TcM TcTyVar
+tcWildCardOcc :: HsWildCardInfo -> Kind -> TcM TcType
 tcWildCardOcc wc_info exp_kind
   = do { wc_tv <- tcLookupTyVar (wildCardName wc_info)
           -- The wildcard's kind should be an un-filled-in meta tyvar
-       ; let Just wc_kind_var = tcGetTyVar_maybe (tyVarKind wc_tv)
-       ; writeMetaTyVar wc_kind_var exp_kind
-       ; return wc_tv }
+       ; checkExpectedKind (HsWildCardTy wc_info) (mkTyVarTy wc_tv)
+                           (tyVarKind wc_tv) exp_kind }
 
 ---------------------------
 -- | Call 'tc_infer_hs_type' and check its result against an expected kind.
-tc_infer_hs_type_ek :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
-tc_infer_hs_type_ek mode ty ek
-  = do { (ty', k) <- tc_infer_hs_type mode ty
-       ; checkExpectedKind ty' k ek }
+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
+tc_infer_hs_type_ek mode hs_ty ek
+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty
+       ; checkExpectedKind hs_ty ty k ek }
 
 ---------------------------
 tupKindSort_maybe :: TcKind -> Maybe TupleSort
 tupKindSort_maybe k
   | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
   | Just k'      <- tcView k            = tupKindSort_maybe k'
-  | isConstraintKind k = Just ConstraintTuple
-  | isLiftedTypeKind k = Just BoxedTuple
-  | otherwise          = Nothing
+  | tcIsConstraintKind k = Just ConstraintTuple
+  | tcIsLiftedTypeKind k   = Just BoxedTuple
+  | otherwise            = Nothing
 
-tc_tuple :: TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
-tc_tuple mode tup_sort tys exp_kind
+tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
+tc_tuple rn_ty mode tup_sort tys exp_kind
   = do { arg_kinds <- case tup_sort of
            BoxedTuple      -> return (nOfThem arity liftedTypeKind)
            UnboxedTuple    -> mapM (\_ -> newOpenTypeKind) tys
            ConstraintTuple -> return (nOfThem arity constraintKind)
        ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
-       ; finish_tuple tup_sort tau_tys arg_kinds exp_kind }
+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }
   where
     arity   = length tys
 
-finish_tuple :: TupleSort
+finish_tuple :: HsType GhcRn
+             -> TupleSort
              -> [TcType]    -- ^ argument types
              -> [TcKind]    -- ^ of these kinds
              -> TcKind      -- ^ expected kind of the whole tuple
              -> TcM TcType
-finish_tuple tup_sort tau_tys tau_kinds exp_kind
+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
   = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
        ; let arg_tys  = case tup_sort of
                    -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
@@ -766,10 +834,10 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind
                                ; checkWiredInTyCon tc
                                ; return tc }
            UnboxedTuple  -> return (tupleTyCon Unboxed arity)
-       ; checkExpectedKind (mkTyConApp tycon arg_tys) res_kind exp_kind }
+       ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }
   where
     arity = length tau_tys
-    tau_reps = map (getRuntimeRepFromKind "finish_tuple") tau_kinds
+    tau_reps = map getRuntimeRepFromKind tau_kinds
     res_kind = case tup_sort of
                  UnboxedTuple    -> unboxedTupleKind tau_reps
                  BoxedTuple      -> liftedTypeKind
@@ -783,165 +851,214 @@ bigConstraintTuple arity
 
 ---------------------------
 -- | Apply a type of a given kind to a list of arguments. This instantiates
--- invisible parameters as necessary. However, it does *not* necessarily
--- apply all the arguments, if the kind runs out of binders.
--- Never calls 'matchExpectedFunKind'; when the kind runs out of binders,
--- this stops processing.
+-- invisible parameters as necessary. Always consumes all the arguments,
+-- using matchExpectedFunKind as necessary.
 -- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.
 -- These kinds should be used to instantiate invisible kind variables;
 -- they come from an enclosing class for an associated type/data family.
--- This version will instantiate all invisible arguments left over after
--- the visible ones. Used only when typechecking type/data family patterns
--- (where we need to instantiate all remaining invisible parameters; for
--- example, consider @type family F :: k where F = Int; F = Maybe@. We
--- need to instantiate the @k@.)
-tcInferArgs :: Outputable fun
-            => fun                      -- ^ the function
-            -> [TyConBinder]            -- ^ function kind's binders
-            -> Maybe (VarEnv Kind)      -- ^ possibly, kind info (see above)
-            -> [LHsType GhcRn]          -- ^ args
-            -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType GhcRn], Int)
-               -- ^ (instantiating subst, un-insted leftover binders,
-               --   typechecked args, untypechecked args, n)
-tcInferArgs fun tc_binders mb_kind_info args
-  = do { let binders = tyConBindersTyBinders tc_binders  -- UGH!
-       ; (subst, leftover_binders, args', leftovers, n)
-           <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1
-        -- now, we need to instantiate any remaining invisible arguments
-       ; let (invis_bndrs, other_binders) = break isVisibleBinder leftover_binders
-       ; (subst', invis_args)
-           <- tcInstBinders subst mb_kind_info invis_bndrs
-       ; return ( subst'
-                , other_binders
-                , args' `chkAppend` invis_args
-                , leftovers, n ) }
-
--- | See comments for 'tcInferArgs'. But this version does not instantiate
--- any remaining invisible arguments.
-tc_infer_args :: Outputable fun
-              => TcTyMode
-              -> fun                      -- ^ the function
-              -> [TyBinder]               -- ^ function kind's binders (zonked)
-              -> Maybe (VarEnv Kind)      -- ^ possibly, kind info (see above)
-              -> [LHsType GhcRn]          -- ^ args
-              -> Int                      -- ^ number to start arg counter at
-              -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType GhcRn], Int)
-tc_infer_args mode orig_ty binders mb_kind_info orig_args n0
-  = go emptyTCvSubst binders orig_args n0 []
+tcInferApps :: TcTyMode
+            -> Maybe (VarEnv Kind)  -- ^ Possibly, kind info (see above)
+            -> LHsType GhcRn        -- ^ Function (for printing only)
+            -> TcType               -- ^ Function
+            -> TcKind               -- ^ Function kind (zonked)
+            -> [LHsType GhcRn]      -- ^ Args
+            -> TcM (TcType, [TcType], TcKind) -- ^ (f args, args, result kind)
+-- Precondition: typeKind fun_ty = fun_ki
+--    Reason: we will return a type application like (fun_ty arg1 ... argn),
+--            and that type must be well-kinded
+--            See Note [The tcType invariant]
+-- Postcondition: Result kind is zonked.
+tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
+       ; (f_args, args, res_k) <- go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args
+       ; traceTc "tcInferApps }" empty
+       ; res_k <- zonkTcType res_k  -- nec'y to uphold (IT4) of Note [The tcType invariant]
+       ; return (f_args, args, res_k) }
   where
-    go subst binders []   n acc
-      = return ( subst, binders, reverse acc, [], n )
-    -- when we call this when checking type family patterns, we really
-    -- do want to instantiate all invisible arguments. During other
-    -- typechecking, we don't.
-
-    go subst (binder:binders) all_args@(arg:args) n acc
-      | isInvisibleBinder binder
-      = do { traceTc "tc_infer_args (invis)" (ppr binder)
-           ; (subst', arg') <- tcInstBinder mb_kind_info subst binder
-           ; go subst' binders all_args n (arg' : acc) }
+    empty_subst                      = mkEmptyTCvSubst $ mkInScopeSet $
+                                       tyCoVarsOfType fun_ki
+    (orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki
+
+    go :: Int             -- the # of the next argument
+       -> [TcType]        -- already type-checked args, in reverse order
+       -> TCvSubst        -- instantiating substitution
+       -> TcType          -- function applied to some args
+       -> [TyBinder]      -- binders in function kind (both vis. and invis.)
+       -> TcKind          -- function kind body (not a Pi-type)
+       -> [LHsType GhcRn] -- un-type-checked args
+       -> TcM (TcType, [TcType], TcKind)  -- same as overall return type
+
+      -- no user-written args left. We're done!
+    go _ acc_args subst fun ki_binders inner_ki []
+      = return ( fun
+               , reverse acc_args
+               , nakedSubstTy subst $ mkPiTys ki_binders inner_ki)
+                 -- nakedSubstTy: see Note [The well-kinded type invariant]
+
+      -- The function's kind has a binder. Is it visible or invisible?
+    go n acc_args subst fun (ki_binder:ki_binders) inner_ki
+       all_args@(arg:args)
+      | isInvisibleBinder ki_binder
+        -- It's invisible. Instantiate.
+      = do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst)
+           ; (subst', arg') <- tcInstTyBinder mb_kind_info subst ki_binder
+           ; go n (arg' : acc_args) subst' (mkNakedAppTy fun arg')
+                ki_binders inner_ki all_args }
 
       | otherwise
-      = do { traceTc "tc_infer_args (vis)" (ppr binder $$ ppr arg)
-           ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $
-                     tc_lhs_type mode arg (substTyUnchecked subst $
-                                           tyBinderType binder)
-           ; let subst' = extendTvSubstBinder subst binder arg'
-           ; go subst' binders args (n+1) (arg' : acc) }
+        -- It's visible. Check the next user-written argument
+      = do { traceTc "tcInferApps (vis)" (vcat [ ppr ki_binder, ppr arg
+                                               , ppr (tyBinderType ki_binder)
+                                               , ppr subst ])
+           ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
+                            -- nakedSubstTy: see Note [The well-kinded type invariant]
+           ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
+                     tc_lhs_type mode arg exp_kind
+           ; traceTc "tcInferApps (vis 1)" (ppr exp_kind)
+           ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
+           ; go (n+1) (arg' : acc_args) subst'
+                (mkNakedAppTy fun arg') -- See Note [The well-kinded type invariant]
+                ki_binders inner_ki args }
+
+       -- We've run out of known binders in the functions's kind.
+    go n acc_args subst fun [] inner_ki all_args
+      | not (null new_ki_binders)
+         -- But, after substituting, we have more binders.
+      = go n acc_args zapped_subst fun new_ki_binders new_inner_ki all_args
 
-    go subst [] all_args n acc
-      = return (subst, [], reverse acc, all_args, n)
+      | otherwise
+         -- Even after substituting, still no binders. Use matchExpectedFunKind
+      = do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)
+           ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki
+           ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]
+                 subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope
+           ; go n acc_args subst'
+                (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]
+                [mkAnonBinder arg_k]
+                res_k all_args }
+      where
+        substed_inner_ki               = substTy subst inner_ki
+        (new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki
+        zapped_subst                   = zapTCvSubst subst
+        hs_ty = mkHsAppTys orig_hs_ty (take (n-1) orig_hs_args)
 
 -- | Applies a type to a list of arguments.
 -- Always consumes all the arguments, using 'matchExpectedFunKind' as
 -- necessary. If you wish to apply a type to a list of HsTypes, this is
 -- your function.
 -- Used for type-checking types only.
-tcInferApps :: Outputable fun
-            => TcTyMode
-            -> fun                  -- ^ Function (for printing only)
-            -> TcType               -- ^ Function (could be knot-tied)
-            -> TcKind               -- ^ Function kind (zonked)
-            -> [LHsType GhcRn]      -- ^ Args
-            -> TcM (TcType, TcKind) -- ^ (f args, result kind)
-tcInferApps mode orig_ty ty ki args = go ty ki args 1
-  where
-    go fun fun_kind []   _ = return (fun, fun_kind)
-    go fun fun_kind args n
-      | let (binders, res_kind) = splitPiTys fun_kind
-      , not (null binders)
-      = do { (subst, leftover_binders, args', leftover_args, n')
-                <- tc_infer_args mode orig_ty binders Nothing args n
-           ; let fun_kind' = substTyUnchecked subst $
-                             mkPiTys leftover_binders res_kind
-           ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' }
-
-    go fun fun_kind all_args@(arg:args) n
-      = do { (co, arg_k, res_k) <- matchExpectedFunKind (length all_args)
-                                                        fun fun_kind
-           ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $
-                     tc_lhs_type mode arg arg_k
-           ; go (mkNakedAppTy (fun `mkNakedCastTy` co) arg')
-                res_k args (n+1) }
+tcTyApps :: TcTyMode
+         -> LHsType GhcRn        -- ^ Function (for printing only)
+         -> TcType               -- ^ Function
+         -> TcKind               -- ^ Function kind (zonked)
+         -> [LHsType GhcRn]      -- ^ Args
+         -> TcM (TcType, TcKind) -- ^ (f args, result kind)   result kind is zonked
+-- Precondition: see precondition for tcInferApps
+tcTyApps mode orig_hs_ty fun_ty fun_ki args
+  = do { (ty', _args, ki') <- tcInferApps mode Nothing orig_hs_ty fun_ty fun_ki args
+       ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') }
+          -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant]
 
 --------------------------
-checkExpectedKind :: TcType               -- the type whose kind we're checking
-                  -> TcKind               -- the known kind of that type, k
-                  -> TcKind               -- the expected kind, exp_kind
-                  -> TcM TcType    -- a possibly-inst'ed, casted type :: exp_kind
+-- Like checkExpectedKindX, but returns only the final type; convenient wrapper
+-- Obeys Note [The tcType invariant]
+checkExpectedKind :: HasDebugCallStack
+                  => HsType GhcRn   -- type we're checking (for printing)
+                  -> TcType         -- type we're checking
+                  -> TcKind         -- the known kind of that type
+                  -> TcKind         -- the expected kind
+                  -> TcM TcType
+checkExpectedKind hs_ty ty act exp
+  = fstOf3 <$> checkExpectedKindX Nothing (ppr hs_ty) ty act exp
+
+checkExpectedKindX :: HasDebugCallStack
+                   => Maybe (VarEnv Kind)  -- Possibly, instantiations for kind vars
+                   -> SDoc                 -- HsType whose kind we're checking
+                   -> TcType               -- the type whose kind we're checking
+                   -> TcKind               -- the known kind of that type, k
+                   -> TcKind               -- the expected kind, exp_kind
+                   -> TcM (TcType, [TcType], TcCoercionN)
+    -- (the new args, the coercion)
 -- Instantiate a kind (if necessary) and then call unifyType
 --      (checkExpectedKind ty act_kind exp_kind)
 -- checks that the actual kind act_kind is compatible
 --      with the expected kind exp_kind
-checkExpectedKind ty act_kind exp_kind
- = do { (ty', act_kind') <- instantiate ty act_kind exp_kind
+checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind
+ = do { -- We need to make sure that both kinds have the same number of implicit
+        -- foralls out front. If the actual kind has more, instantiate accordingly.
+        -- Otherwise, just pass the type & kind through: the errors are caught
+        -- in unifyType.
+        let (exp_bndrs, _) = splitPiTysInvisible exp_kind
+            n_exp          = length exp_bndrs
+      ; (new_args, act_kind') <- instantiateTyUntilN mb_kind_env n_exp act_kind
+
       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
                                   , uo_expected = exp_kind
-                                  , uo_thing    = Just $ mkTypeErrorThing ty'
-                                  }
-      ; co_k <- uType origin KindLevel act_kind' exp_kind
-      ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
-                                          , ppr exp_kind
-                                          , ppr co_k ])
-      ; let result_ty = ty' `mkNakedCastTy` co_k
-      ; return result_ty }
-  where
-    -- we need to make sure that both kinds have the same number of implicit
-    -- foralls out front. If the actual kind has more, instantiate accordingly.
-    -- Otherwise, just pass the type & kind through -- the errors are caught
-    -- in unifyType.
-    instantiate :: TcType    -- the type
-                -> TcKind    -- of this kind
-                -> TcKind   -- but expected to be of this one
-                -> TcM ( TcType   -- the inst'ed type
-                       , TcKind ) -- its new kind
-    instantiate ty act_ki exp_ki
-      = let (exp_bndrs, _) = splitPiTysInvisible exp_ki in
-        instantiateTyN (length exp_bndrs) ty act_ki
+                                  , uo_thing    = Just pp_hs_ty
+                                  , uo_visible  = True } -- the hs_ty is visible
+            ty' = mkNakedAppTys ty new_args
+
+      ; traceTc "checkExpectedKind" $
+        vcat [ pp_hs_ty
+             , text "act_kind:" <+> ppr act_kind
+             , text "act_kind':" <+> ppr act_kind'
+             , text "exp_kind:" <+> ppr exp_kind ]
+
+      ; if act_kind' `tcEqType` exp_kind
+        then return (ty', new_args, mkTcNomReflCo exp_kind)  -- This is very common
+        else do { co_k <- uType KindLevel origin act_kind' exp_kind
+                ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
+                                                    , ppr exp_kind
+                                                    , ppr co_k ])
+                ; let result_ty = ty' `mkNakedCastTy` co_k
+                      -- See Note [The tcType invariant]
+                ; return (result_ty, new_args, co_k) } }
+
+-- | Instantiate @n@ invisible arguments to a type. If @n <= 0@, no instantiation
+-- occurs. If @n@ is too big, then all available invisible arguments are instantiated.
+-- (In other words, this function is very forgiving about bad values of @n@.)
+-- Why zonk the result? So that tcTyVar can obey (IT6) of Note [The tcType invariant]
+instantiateTyN :: Maybe (VarEnv Kind)              -- ^ Predetermined instantiations
+                                                   -- (for assoc. type patterns)
+               -> Int                              -- ^ @n@
+               -> [TyBinder] -> TcKind             -- ^ its kind (zonked)
+               -> TcM ([TcType], TcKind)   -- ^ The inst'ed type, new args, kind (zonked)
+instantiateTyN mb_kind_env n bndrs inner_ki
+  | n <= 0
+  = return ([], ki)
 
--- | Instantiate a type to have at most @n@ invisible arguments.
-instantiateTyN :: Int    -- ^ @n@
-               -> TcType -- ^ the type
-               -> TcKind -- ^ its kind
-               -> TcM (TcType, TcKind)   -- ^ The inst'ed type with kind
-instantiateTyN n ty ki
-  = let (bndrs, inner_ki)            = splitPiTysInvisible ki
-        num_to_inst                  = length bndrs - n
-           -- NB: splitAt is forgiving with invalid numbers
-        (inst_bndrs, leftover_bndrs) = splitAt num_to_inst bndrs
-        empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki))
-    in
-    if num_to_inst <= 0 then return (ty, ki) else
-    do { (subst, inst_args) <- tcInstBinders empty_subst Nothing inst_bndrs
+  | otherwise
+  = do { (subst, inst_args) <- tcInstTyBinders empty_subst mb_kind_env inst_bndrs
        ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki
-             ki'        = substTy subst rebuilt_ki
-       ; traceTc "instantiateTyN" (vcat [ ppr ty <+> dcolon <+> ppr ki
+       ; ki' <- zonkTcType (substTy subst rebuilt_ki)
+       ; traceTc "instantiateTyN" (vcat [ ppr ki
+                                        , ppr n
                                         , ppr subst
                                         , ppr rebuilt_ki
                                         , ppr ki' ])
-       ; return (mkNakedAppTys ty inst_args, ki') }
+       ; return (inst_args, ki') }
+  where
+     -- NB: splitAt is forgiving with invalid numbers
+     (inst_bndrs, leftover_bndrs) = splitAt n bndrs
+     ki          = mkPiTys bndrs inner_ki
+     empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki))
+
+-- | Instantiate a type to have at most @n@ invisible arguments.
+instantiateTyUntilN :: Maybe (VarEnv Kind)   -- ^ Possibly, instantiations for vars
+                    -> Int         -- ^ @n@
+                    -> TcKind      -- ^ its kind
+                    -> TcM ([TcType], TcKind)   -- ^ The new args, final kind
+instantiateTyUntilN mb_kind_env n ki
+  = let (bndrs, inner_ki) = splitPiTysInvisible ki
+        num_to_inst       = length bndrs - n
+    in
+    instantiateTyN mb_kind_env num_to_inst bndrs inner_ki
 
 ---------------------------
+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
+tcHsMbContext Nothing    = return []
+tcHsMbContext (Just cxt) = tcHsContext cxt
+
 tcHsContext :: LHsContext GhcRn -> TcM [PredType]
 tcHsContext = tc_hs_context typeLevelMode
 
@@ -962,134 +1079,98 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
   = do { traceTc "lk1" (ppr name)
        ; thing <- tcLookup name
        ; case thing of
-           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
+           ATyVar _ tv -> -- Important: zonk before returning
+                          -- We may have the application ((a::kappa) b)
+                          -- where kappa is already unified to (k1 -> k2)
+                          -- Then we want to see that arrow.  Best done
+                          -- here because we are also maintaining
+                          -- Note [The tcType invariant], so we don't just
+                          -- want to zonk the kind, leaving the TyVar
+                          -- un-zonked  (Trac #14873)
+                          do { ty <- zonkTcTyVar tv
+                             ; return (ty, typeKind ty) }
 
            ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference]
                                   unless
                                     (isTypeLevel (mode_level mode))
                                     (promotionErr name TyConPE)
                                 ; check_tc tc_tc
-                                ; tc <- get_loopy_tc name tc_tc
-                                ; handle_tyfams tc tc_tc }
-                             -- mkNakedTyConApp: see Note [Type-checking inside the knot]
-                 -- NB: we really should check if we're at the kind level
-                 -- and if the tycon is promotable if -XNoTypeInType is set.
-                 -- But this is a terribly large amount of work! Not worth it.
+                                ; handle_tyfams tc_tc }
 
            AGlobal (ATyCon tc)
              -> do { check_tc tc
-                   ; handle_tyfams tc tc }
+                   ; handle_tyfams tc }
 
            AGlobal (AConLike (RealDataCon dc))
              -> do { data_kinds <- xoptM LangExt.DataKinds
                    ; unless (data_kinds || specialPromotedDc dc) $
                        promotionErr name NoDataKindsDC
-                   ; type_in_type <- xoptM LangExt.TypeInType
-                   ; unless ( type_in_type ||
-                              ( isTypeLevel (mode_level mode) &&
-                                isLegacyPromotableDataCon dc ) ||
-                              ( isKindLevel (mode_level mode) &&
-                                specialPromotedDc dc ) ) $
-                       promotionErr name NoTypeInTypeDC
+                   ; when (isFamInstTyCon (dataConTyCon dc)) $
+                       -- see Trac #15245
+                       promotionErr name FamDataConPE
+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc
+                   ; case dc_theta_illegal_constraint theta of
+                       Just pred -> promotionErr name $
+                                    ConstrainedDataConPE pred
+                       Nothing   -> pure ()
                    ; let tc = promoteDataCon dc
-                   ; return (mkNakedTyConApp tc [], tyConKind tc) }
+                   ; return (mkTyConApp tc [], tyConKind tc) }
 
            APromotionErr err -> promotionErr name err
 
            _  -> wrongThingErr "type" thing name }
   where
     check_tc :: TyCon -> TcM ()
-    check_tc tc = do { type_in_type <- xoptM LangExt.TypeInType
-                     ; data_kinds   <- xoptM LangExt.DataKinds
+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds
                      ; unless (isTypeLevel (mode_level mode) ||
                                data_kinds ||
                                isKindTyCon tc) $
-                       promotionErr name NoDataKindsTC
-                     ; unless (isTypeLevel (mode_level mode) ||
-                               type_in_type ||
-                               isLegacyPromotableTyCon tc) $
-                       promotionErr name NoTypeInTypeTC }
+                       promotionErr name NoDataKindsTC }
 
     -- if we are type-checking a type family tycon, we must instantiate
     -- any invisible arguments right away. Otherwise, we get #11246
-    handle_tyfams :: TyCon   -- the tycon to instantiate (might be loopy)
-                  -> TyCon   -- a non-loopy version of the tycon
+    handle_tyfams :: TyCon     -- the tycon to instantiate
                   -> TcM (TcType, TcKind)
-    handle_tyfams tc tc_tc
-      | mightBeUnsaturatedTyCon tc_tc
-      = do { traceTc "tcTyVar2a" (ppr tc_tc $$ ppr tc_kind)
-           ; return (ty, tc_kind) }
+    handle_tyfams tc
+      | mightBeUnsaturatedTyCon tc || mode_unsat mode
+                                         -- This is where mode_unsat is used
+      = do { tc_kind <- zonkTcType (tyConKind tc)   -- (IT6) of Note [The tcType invariant]
+           ; traceTc "tcTyVar2a" (ppr tc $$ ppr tc_kind)
+           ; return (mkTyConApp tc [] `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) }
+              -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]
 
       | otherwise
-      = do { (tc_ty, kind) <- instantiateTyN 0 ty tc_kind
-           -- tc and tc_ty must not be traced here, because that would
-           -- force the evaluation of a potentially knot-tied variable (tc),
-           -- and the typechecker would hang, as per #11708
-           ; traceTc "tcTyVar2b" (vcat [ ppr tc_tc <+> dcolon <+> ppr tc_kind
+      = do { tc_kind <- zonkTcType (tyConKind tc)
+           ; let (tc_kind_bndrs, tc_inner_ki) = splitPiTysInvisible tc_kind
+           ; (tc_args, kind) <- instantiateTyN Nothing (length (tyConBinders tc))
+                                               tc_kind_bndrs tc_inner_ki
+           ; let is_saturated = tc_args `lengthAtLeast` tyConArity tc
+                 tc_ty
+                   | is_saturated = mkTyConApp tc tc_args `mkNakedCastTy` mkNomReflCo kind
+                      -- mkNakedCastTy is for (IT5) of Note [The tcType invariant]
+                   | otherwise    = mkTyConApp tc tc_args
+                      -- if the tycon isn't yet saturated, then we don't want mkNakedCastTy,
+                      -- because that means we'll have an unsaturated type family
+                      -- We don't need it anyway, because we can be sure that the
+                      -- type family kind will accept further arguments (because it is
+                      -- not yet saturated)
+           ; traceTc "tcTyVar2b" (vcat [ ppr tc <+> dcolon <+> ppr tc_kind
                                        , ppr kind ])
            ; return (tc_ty, kind) }
-      where
-        ty      = mkNakedTyConApp tc []
-        tc_kind = tyConKind tc_tc
-
-    get_loopy_tc :: Name -> TyCon -> TcM TyCon
-    -- Return the knot-tied global TyCon if there is one
-    -- Otherwise the local TcTyCon; we must be doing kind checking
-    -- but we still want to return a TyCon of some sort to use in
-    -- error messages
-    get_loopy_tc name tc_tc
-      = do { env <- getGblEnv
-           ; case lookupNameEnv (tcg_type_env env) name of
-                Just (ATyCon tc) -> return tc
-                _                -> do { traceTc "lk1 (loopy)" (ppr name)
-                                       ; return tc_tc } }
-
-tcClass :: Name -> TcM (Class, TcKind)
-tcClass cls     -- Must be a class
-  = do { thing <- tcLookup cls
-       ; case thing of
-           ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc)
-           AGlobal (ATyCon tc)
-             | Just cls <- tyConClass_maybe tc
-             -> return (cls, tyConKind tc)
-           _ -> wrongThingErr "class" thing cls }
 
-
-aThingErr :: String -> Name -> b
--- The type checker for types is sometimes called simply to
--- do *kind* checking; and in that case it ignores the type
--- returned. Which is a good thing since it may not be available yet!
-aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x)
+    -- We cannot promote a data constructor with a context that contains
+    -- constraints other than equalities, so error if we find one.
+    -- See Note [Constraints handled in types] in Inst.
+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
+    dc_theta_illegal_constraint = find go
+      where
+        go :: PredType -> Bool
+        go pred | Just tc <- tyConAppTyCon_maybe pred
+                = not $  tc `hasKey` eqTyConKey
+                      || tc `hasKey` heqTyConKey
+                | otherwise = True
 
 {-
-Note [Type-checking inside the knot]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are checking the argument types of a data constructor.  We
-must zonk the types before making the DataCon, because once built we
-can't change it.  So we must traverse the type.
-
-BUT the parent TyCon is knot-tied, so we can't look at it yet.
-
-So we must be careful not to use "smart constructors" for types that
-look at the TyCon or Class involved.
-
-  * Hence the use of mkNakedXXX functions. These do *not* enforce
-    the invariants (for example that we use (FunTy s t) rather
-    than (TyConApp (->) [s,t])).
-
-  * The zonking functions establish invariants (even zonkTcType, a change from
-    previous behaviour). So we must never inspect the result of a
-    zonk that might mention a knot-tied TyCon. This is generally OK
-    because we zonk *kinds* while kind-checking types. And the TyCons
-    in kinds shouldn't be knot-tied, because they come from a previous
-    mutually recursive group.
-
-  * TcHsSyn.zonkTcTypeToType also can safely check/establish
-    invariants.
-
-This is horribly delicate.  I hate it.  A good example of how
-delicate it is can be seen in Trac #7903.
-
 Note [GADT kind self-reference]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1225,14 +1306,13 @@ in the e2 example, we'll desugar the type, zonking the kind unification
 variables as we go.  When we encounter the unconstrained kappa, we
 want to default it to '*', not to (Any *).
 
-
 Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -}
 
 addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
         -- Wrap a context around only if we want to show that contexts.
-        -- Omit invisble ones and ones user's won't grok
+        -- Omit invisible ones and ones user's won't grok
 addTypeCtxt (L _ ty) thing
   = addErrCtxt doc thing
   where
@@ -1245,108 +1325,227 @@ addTypeCtxt (L _ ty) thing
 %*                                                                      *
 %************************************************************************
 
-Note [Scope-check inferred kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data SameKind :: k -> k -> *
-  foo :: forall a (b :: Proxy a) (c :: Proxy d). SameKind b c
-
-d has no binding site. So it gets bound implicitly, at the top. The
-problem is that d's kind mentions `a`. So it's all ill-scoped.
-
-The way we check for this is to gather all variables *bound* in a
-type variable's scope. The type variable's kind should not mention
-any of these variables. That is, d's kind can't mention a, b, or c.
-We can't just check to make sure that d's kind is in scope, because
-we might be about to kindGeneralize.
-
-A little messy, but it works.
-
 Note [Dependent LHsQTyVars]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We track (in the renamer) which explicitly bound variables in a
 LHsQTyVars are manifestly dependent; only precisely these variables
-may be used within the LHsQTyVars. We must do this so that kcHsTyVarBndrs
-can produce the right TyConBinders, and tell Anon vs. Named. Earlier,
-I thought it would work simply to do a free-variable check during
-kcHsTyVarBndrs, but this is bogus, because there may be unsolved
-equalities about. And we don't want to eagerly solve the equalities,
-because we may get further information after kcHsTyVarBndrs is called.
-(Recall that kcHsTyVarBndrs is usually called from getInitialKind.
-The only other case is in kcConDecl.) This is what implements the rule
-that all variables intended to be dependent must be manifestly so.
+may be used within the LHsQTyVars. We must do this so that kcLHsQTyVars
+can produce the right TyConBinders, and tell Anon vs. Required.
+
+Example   data T k1 (a:k1) (b:k2) c
+               = MkT (Proxy a) (Proxy b) (Proxy c)
+
+Here
+  (a:k1),(b:k2),(c:k3)
+       are Anon     (explicitly specified as a binder, not used
+                     in the kind of any other binder
+  k1   is Required  (explicitly specifed as a binder, but used
+                     in the kind of another binder i.e. dependently)
+  k2   is Specified (not explicitly bound, but used in the kind
+                     of another binder)
+  k3   in Inferred  (not lexically in scope at all, but inferred
+                     by kind inference)
+and
+  T :: forall {k3} k1. forall k3 -> k1 -> k2 -> k3 -> *
+
+See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+in TyCoRep.
+
+kcLHsQTyVars uses the hsq_dependent field to decide whether
+k1, a, b, c should be Required or Anon.
+
+Earlier, thought it would work simply to do a free-variable check
+during kcLHsQTyVars, but this is bogus, because there may be
+unsolved equalities about. And we don't want to eagerly solve the
+equalities, because we may get further information after
+kcLHsQTyVars is called.  (Recall that kcLHsQTyVars is called
+only from getInitialKind.)
+This is what implements the rule that all variables intended to be
+dependent must be manifestly so.
 
 Sidenote: It's quite possible that later, we'll consider (t -> s)
 as a degenerate case of some (pi (x :: t) -> s) and then this will
 all get more permissive.
 
+Note [Kind generalisation and TyVarTvs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T (a :: k1) x = MkT (S a ())
+  data S (b :: k2) y = MkS (T b ())
+
+While we are doing kind inference for the mutually-recursive S,T,
+we will end up unifying k1 and k2 together. So they can't be skolems.
+We therefore make them TyVarTvs, which can unify with type variables,
+but not with general types.  All this is very similar at the level
+of terms: see Note [Quantified variables in partial type signatures]
+in TcBinds.
+
+There are some wrinkles
+
+* We always want to kind-generalise over TyVarTvs, and /not/ default
+  them to Type.  Another way to say this is: a SigTV should /never/
+  stand for a type, even via defaulting. Hence the check in
+  TcSimplify.defaultTyVarTcS, and TcMType.defaultTyVar.  Here's
+  another example (Trac #14555):
+     data Exp :: [TYPE rep] -> TYPE rep -> Type where
+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
+  We want to kind-generalise over the 'rep' variable.
+  Trac #14563 is another example.
+
+* Consider Trac #11203
+    data SameKind :: k -> k -> *
+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
+  Here we will unify k1 with k2, but this time doing so is an error,
+  because k1 and k2 are bound in the same delcaration.
+
+  We sort this out using findDupTyVarTvs, in TcTyClTyVars; very much
+  as we do with partial type signatures in mk_psig_qtvs in
+  TcBinds.chooseInferredQuantifiers
+
+Note [Keeping scoped variables in order: Explicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user writes `forall a b c. blah`, we bring a, b, and c into
+scope and then check blah. In the process of checking blah, we might
+learn the kinds of a, b, and c, and these kinds might indicate that
+b depends on c, and thus that we should reject the user-written type.
+
+One approach to doing this would be to bring each of a, b, and c into
+scope, one at a time, creating an implication constraint and
+bumping the TcLevel for each one. This would work, because the kind
+of, say, b would be untouchable when c is in scope (and the constraint
+couldn't float out because c blocks it). However, it leads to terrible
+error messages, complaining about skolem escape. While it is indeed
+a problem of skolem escape, we can do better.
+
+Instead, our approach is to bring the block of variables into scope
+all at once, creating one implication constraint for the lot. The
+user-written variables are skolems in the implication constraint. In
+TcSimplify.setImplicationStatus, we check to make sure that the ordering
+is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.
+Then, in TcErrors, we report if there is a bad telescope. This way,
+we can report a suggested ordering to the user if there is a problem.
+
+Note [Keeping scoped variables in order: Implicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user implicitly quantifies over variables (say, in a type
+signature), we need to come up with some ordering on these variables.
+This is done by bumping the TcLevel, bringing the tyvars into scope,
+and then type-checking the thing_inside. The constraints are all
+wrapped in an implication, which is then solved. Finally, we can
+zonk all the binders and then order them with toposortTyVars.
+
+It's critical to solve before zonking and ordering in order to uncover
+any unifications. You might worry that this eager solving could cause
+trouble elsewhere. I don't think it will. Because it will solve only
+in an increased TcLevel, it can't unify anything that was mentioned
+elsewhere. Additionally, we require that the order of implicitly
+quantified variables is manifest by the scope of these variables, so
+we're not going to learn more information later that will help order
+these variables.
+
+Note [Recipe for checking a signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Checking a user-written signature requires several steps:
+
+ 1. Generate constraints.
+ 2. Solve constraints.
+ 3. Zonk.
+ 4. Promote tyvars and/or kind-generalize.
+ 5. Zonk.
+ 6. Check validity.
+
+There may be some surprises in here:
+
+Step 2 is necessary for two reasons: most signatures also bring
+implicitly quantified variables into scope, and solving is necessary
+to get these in the right order (see Note [Keeping scoped variables in
+order: Implicit]). Additionally, solving is necessary in order to
+kind-generalize correctly.
+
+In Step 4, we have to deal with the fact that metatyvars generated
+in the type may have a bumped TcLevel, because explicit foralls
+raise the TcLevel. To avoid these variables from ever being visible
+in the surrounding context, we must obey the following dictum:
+
+  Every metavariable in a type must either be
+    (A) promoted, or
+    (B) generalized.
+
+If a variable is generalized, then it becomes a skolem and no longer
+has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as
+it's not really in play here.) On the other hand, if it is not
+generalized (because we're not generalizing the construct -- e.g., pattern
+sig -- or because the metavars are constrained -- see kindGeneralizeLocal)
+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]
+in TcType.
+
+After promoting/generalizing, we need to zonk *again* because both
+promoting and generalizing fill in metavariables.
+
+To avoid the double-zonk, we do two things:
+ 1. When we're not generalizing:
+    zonkPromoteType and friends zonk and promote at the same time.
+    Accordingly, the function does steps 3-5 all at once, preventing
+    the need for multiple traversals.
+
+ 2. When we are generalizing:
+    kindGeneralize does not require a zonked type -- it zonks as it
+    gathers free variables. So this way effectively sidesteps step 3.
+
 -}
 
 tcWildCardBinders :: [Name]
                   -> ([(Name, TcTyVar)] -> TcM a)
                   -> TcM a
-tcWildCardBinders = tcWildCardBindersX new_tv
-  where
-    new_tv name = do { kind <- newMetaKindVar
-                     ; newSkolemTyVar name kind }
-
-tcWildCardBindersX :: (Name -> TcM TcTyVar)
-                   -> [Name]
-                   -> ([(Name, TcTyVar)] -> TcM a)
-                   -> TcM a
-tcWildCardBindersX new_wc wc_names thing_inside
-  = do { wcs <- mapM new_wc wc_names
+tcWildCardBinders wc_names thing_inside
+  = do { wcs <- mapM newWildTyVar wc_names
        ; let wc_prs = wc_names `zip` wcs
-       ; tcExtendTyVarEnv2 wc_prs $
+       ; tcExtendNameTyVarEnv wc_prs $
          thing_inside wc_prs }
 
 -- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
 -- user-supplied kind signature (CUSK), generalise the result.
 -- Used in 'getInitialKind' (for tycon kinds and other kinds)
 -- and in kind-checking (but not for tycon kinds, which are checked with
--- tcTyClDecls). See also Note [Complete user-supplied kind signatures] in
--- HsDecls.
+-- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]
+-- in HsDecls.
 --
 -- This function does not do telescope checking.
-kcHsTyVarBndrs :: Name    -- ^ of the thing being checked
-               -> TyConFlavour -- ^ What sort of 'TyCon' is being checked
-               -> Bool    -- ^ True <=> the decl being checked has a CUSK
-               -> Bool    -- ^ True <=> all the hsq_implicit are *kind* vars
-                          -- (will give these kind * if -XNoTypeInType)
-               -> LHsQTyVars GhcRn
-               -> TcM (Kind, r)     -- ^ The result kind, possibly with other info
-               -> TcM (TcTyCon, r)  -- ^ A suitably-kinded TcTyCon
-kcHsTyVarBndrs name flav cusk all_kind_vars
-  (HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs
-          , hsq_dependent = dep_names }) thing_inside
+kcLHsQTyVars :: Name              -- ^ of the thing being checked
+             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+             -> Bool              -- ^ True <=> the decl being checked has a CUSK
+             -> LHsQTyVars GhcRn
+             -> TcM Kind          -- ^ The result kind
+             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+kcLHsQTyVars name flav cusk
+  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns
+                                           , hsq_dependent = dep_names }
+                      , hsq_explicit = hs_tvs }) thing_inside
   | cusk
-  = do { kv_kinds <- mk_kv_kinds
-       ; lvl <- getTcLevel
-       ; let scoped_kvs = zipWith (mk_skolem_tv lvl) kv_ns kv_kinds
-       ; tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $
-    do { (tc_binders, res_kind, stuff) <- solveEqualities $
-                                          bind_telescope hs_tvs thing_inside
+  = do { (scoped_kvs, (tc_tvs, res_kind))
+           <- solveEqualities                    $
+              tcImplicitQTKBndrs skol_info kv_ns $
+              kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside
 
            -- Now, because we're in a CUSK, quantify over the mentioned
            -- kind vars, in dependency order.
-       ; tc_binders  <- mapM zonkTcTyVarBinder tc_binders
-       ; res_kind <- zonkTcType res_kind
-       ; let tc_tvs = binderVars tc_binders
-             qkvs   = tyCoVarsOfTypeWellScoped (mkTyConKind tc_binders res_kind)
-                   -- the visibility of tvs doesn't matter here; we just
-                   -- want the free variables not to include the tvs
-
-          -- If there are any meta-tvs left, the user has
-          -- lied about having a CUSK. Error.
-       ; let (meta_tvs, good_tvs) = partition isMetaTyVar qkvs
-       ; when (not (null meta_tvs)) $
-         report_non_cusk_tvs (qkvs ++ tc_tvs)
+       ; let tc_binders_unzonked = zipWith mk_tc_binder hs_tvs tc_tvs
+       ; dvs  <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys scoped_kvs $
+                                            mkTyConKind tc_binders_unzonked res_kind)
+       ; qkvs <- quantifyTyVars emptyVarSet dvs
+         -- don't call tcGetGlobalTyCoVars. For associated types, it gets the
+         -- tyvars from the enclosing class -- but that's wrong. We *do* want
+         -- to quantify over those tyvars.
+
+       ; scoped_kvs <- mapM zonkTcTyVarToTyVar scoped_kvs
+       ; tc_tvs     <- mapM zonkTcTyVarToTyVar tc_tvs
+       ; res_kind   <- zonkTcType res_kind
+       ; let tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs
 
           -- If any of the scoped_kvs aren't actually mentioned in a binder's
           -- kind (or the return kind), then we're in the CUSK case from
           -- Note [Free-floating kind vars]
-       ; let all_tc_tvs        = good_tvs ++ tc_tvs
+       ; let all_tc_tvs        = scoped_kvs ++ tc_tvs
              all_mentioned_tvs = mapUnionVarSet (tyCoVarsOfType . tyVarKind)
                                                 all_tc_tvs
                                  `unionVarSet` tyCoVarsOfType res_kind
@@ -1354,208 +1553,311 @@ kcHsTyVarBndrs name flav cusk all_kind_vars
                                            scoped_kvs
        ; reportFloatingKvs name flav all_tc_tvs unmentioned_kvs
 
-       ; let final_binders = map (mkNamedTyConBinder Specified) good_tvs
-                            ++ tc_binders
-             tycon = mkTcTyCon name final_binders res_kind
-                               (scoped_kvs ++ tc_tvs) flav
+       ; let final_binders =  map (mkNamedTyConBinder Inferred) qkvs
+                           ++ map (mkNamedTyConBinder Specified) scoped_kvs
+                           ++ tc_binders
+             tycon = mkTcTyCon name (ppr user_tyvars) final_binders res_kind
+                               (mkTyVarNamePairs (scoped_kvs ++ tc_tvs))
+                               flav
                            -- the tvs contain the binders already
                            -- in scope from an enclosing class, but
                            -- re-adding tvs to the env't doesn't cause
                            -- harm
-       ; return (tycon, stuff) }}
+
+       ; traceTc "kcLHsQTyVars: cusk" $
+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
+              , ppr tc_tvs, ppr (mkTyConKind final_binders res_kind)
+              , ppr qkvs, ppr final_binders ]
+
+       ; return tycon }
 
   | otherwise
-  = do { kv_kinds <- mk_kv_kinds
-       ; scoped_kvs <- zipWithM newSigTyVar kv_ns kv_kinds
-                     -- the names must line up in splitTelescopeTvs
-       ; (binders, res_kind, stuff)
-           <- tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $
-              bind_telescope hs_tvs thing_inside
+  = do { (scoped_kvs, (tc_tvs, res_kind))
+           -- Why kcImplicitTKBndrs which uses newTyVarTyVar?
+           -- See Note [Kind generalisation and TyVarTvs]
+           <- kcImplicitTKBndrs kv_ns $
+              kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside
+
        ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
                -- must remain lined up with the binders
-             tycon = mkTcTyCon name binders res_kind
-                               (scoped_kvs ++ binderVars binders) flav
-       ; return (tycon, stuff) }
+             tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs
+             tycon = mkTcTyCon name (ppr user_tyvars) tc_binders res_kind
+                               (mkTyVarNamePairs (scoped_kvs ++ tc_tvs))
+                               flav
+
+       ; traceTc "kcLHsQTyVars: not-cusk" $
+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]
+       ; return tycon }
   where
     open_fam = tcFlavourIsOpen flav
-
-      -- if -XNoTypeInType and we know all the implicits are kind vars,
-      -- just give the kind *. This prevents test
-      -- dependent/should_fail/KindLevelsB from compiling, as it should
-    mk_kv_kinds :: TcM [Kind]
-    mk_kv_kinds = do { typeintype <- xoptM LangExt.TypeInType
-                     ; if not typeintype && all_kind_vars
-                       then return (map (const liftedTypeKind) kv_ns)
-                       else mapM (const newMetaKindVar) kv_ns }
-
-      -- there may be dependency between the explicit "ty" vars. So, we have
-      -- to handle them one at a time.
-    bind_telescope :: [LHsTyVarBndr GhcRn]
-                   -> TcM (Kind, r)
-                   -> TcM ([TyConBinder], TcKind, r)
-    bind_telescope [] thing
-      = do { (res_kind, stuff) <- thing
-           ; return ([], res_kind, stuff) }
-    bind_telescope (L _ hs_tv : hs_tvs) thing
-      = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv
+    skol_info = TyConSkol flav name
+
+    mk_tc_binder :: LHsTyVarBndr GhcRn -> TyVar -> TyConBinder
+    -- See Note [Dependent LHsQTyVars]
+    mk_tc_binder hs_tv tv
+       | hsLTyVarName hs_tv `elemNameSet` dep_names
+       = mkNamedTyConBinder Required tv
+       | otherwise
+       = mkAnonTyConBinder tv
+
+kcLHsQTyVars _ _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+kcLHsQTyVarBndrs :: Bool   -- True <=> bump the TcLevel when bringing vars into scope
+                 -> Bool   -- True <=> Default un-annotated tyvar
+                           --          binders to kind *
+                 -> SkolemInfo
+                 -> [LHsTyVarBndr GhcRn]
+                 -> TcM r
+                 -> TcM ([TyVar], r)
+-- There may be dependency between the explicit "ty" vars.
+-- So, we have to handle them one at a time.
+kcLHsQTyVarBndrs _ _ _ [] thing
+  = do { stuff <- thing; return ([], stuff) }
+
+kcLHsQTyVarBndrs cusk open_fam skol_info (L _ hs_tv : hs_tvs) thing
+  = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv
                -- NB: Bring all tvs into scope, even non-dependent ones,
                -- as they're needed in type synonyms, data constructors, etc.
-           ; (binders, res_kind, stuff) <- bind_unless_scoped tv_pair $
-                                           bind_telescope hs_tvs $
-                                           thing
-                  -- See Note [Dependent LHsQTyVars]
-           ; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names
-                            = mkNamedTyConBinder Required tv
-                            | otherwise
-                            = mkAnonTyConBinder tv
-           ; return ( new_binder : binders
-                    , res_kind, stuff ) }
 
+       ; (tvs, stuff) <- bind_unless_scoped tv_pair $
+                         kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs $
+                         thing
+
+       ; return ( tv : tvs, stuff ) }
+  where
     -- | Bind the tyvar in the env't unless the bool is True
     bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a
     bind_unless_scoped (_, True)   thing_inside = thing_inside
     bind_unless_scoped (tv, False) thing_inside
-      = tcExtendTyVarEnv [tv] thing_inside
+      | cusk      = scopeTyVars skol_info [tv] thing_inside
+      | otherwise = tcExtendTyVarEnv      [tv] thing_inside
+         -- These variables haven't settled down yet, so we don't want to bump
+         -- the TcLevel. If we do, then we'll have metavars of too high a level
+         -- floating about. Changing this causes many, many failures in the
+         -- `dependent` testsuite directory.
 
     kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool)
-    kc_hs_tv (UserTyVar (L _ name))
-      = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name
-
-              -- Open type/data families default their variables to kind *.
-           ; when (open_fam && not scoped) $ -- (don't default class tyvars)
-             discardResult $ unifyKind (Just (mkTyVarTy tv)) liftedTypeKind
-                                                             (tyVarKind tv)
-
-           ; return tv_pair }
-
-    kc_hs_tv (KindedTyVar (L _ name) lhs_kind)
-      = do { kind <- tcLHsKindSig lhs_kind
-           ; tcHsTyVarName (Just kind) name }
-
-    report_non_cusk_tvs all_tvs
-      = do { all_tvs <- mapM zonkTyCoVarKind all_tvs
-           ; let (_, tidy_tvs)         = tidyOpenTyCoVars emptyTidyEnv all_tvs
-                 (meta_tvs, other_tvs) = partition isMetaTyVar tidy_tvs
-
-           ; addErr $
-             vcat [ text "You have written a *complete user-suppled kind signature*,"
-                  , hang (text "but the following variable" <> plural meta_tvs <+>
-                          isOrAre meta_tvs <+> text "undetermined:")
-                       2 (vcat (map pp_tv meta_tvs))
-                  , text "Perhaps add a kind signature."
-                  , hang (text "Inferred kinds of user-written variables:")
-                       2 (vcat (map pp_tv other_tvs)) ] }
-      where
-        pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+      -- Special handling for the case where the binder is already in scope
+      -- See Note [Associated type tyvar names] in Class and
+      --     Note [TyVar binders for associated decls] in HsDecls
+    kc_hs_tv (UserTyVar _ (L _ name))
+      = do { mb_tv <- tcLookupLcl_maybe name
+           ; case mb_tv of  -- See Note [TyVar binders for associated decls]
+                Just (ATyVar _ tv) -> return (tv, True)
+                _ -> do { kind <- if open_fam
+                                  then return liftedTypeKind
+                                  else newMetaKindVar
+                                  -- Open type/data families default their variables
+                                  -- variables to kind *.  But don't default in-scope
+                                  -- class tyvars, of course
+                        ; tv <- newSkolemTyVar name kind
+                        ; return (tv, False) } }
+
+    kc_hs_tv (KindedTyVar _ lname@(L _ name) lhs_kind)
+      = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt name) lhs_kind
+           ; mb_tv <- tcLookupLcl_maybe name
+           ; case mb_tv of
+               Just (ATyVar _ tv)
+                 -> do { discardResult $
+                           unifyKind (Just (HsTyVar noExt NotPromoted lname))
+                                     kind (tyVarKind tv)
+                       ; return (tv, True) }
+               _ -> do { tv <- newSkolemTyVar name kind
+                       ; return (tv, False) } }
+
+    kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv"
+
+{- Note [Kind-checking tyvar binders for associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When kind-checking the type-variable binders for associated
+   data/newtype decls
+   family decls
+we behave specially for type variables that are already in scope;
+that is, bound by the enclosing class decl.  This is done in
+kcLHsQTyVarBndrs:
+  * The use of tcImplicitQTKBndrs
+  * The tcLookupLocal_maybe code in kc_hs_tv
+
+See Note [Associated type tyvar names] in Class and
+    Note [TyVar binders for associated decls] in HsDecls
+
+We must do the same for family instance decls, where the in-scope
+variables may be bound by the enclosing class instance decl.
+Hence the use of tcImplicitQTKBndrs in tcFamTyPats.
+-}
 
 
-tcImplicitTKBndrs :: [Name]
-                  -> TcM (a, TyVarSet)   -- vars are bound somewhere in the scope
-                                         -- see Note [Scope-check inferred kinds]
-                  -> TcM ([TcTyVar], a)
-tcImplicitTKBndrs = tcImplicitTKBndrsX (tcHsTyVarName Nothing)
-
--- | Convenient specialization
-tcImplicitTKBndrsType :: [Name]
-                      -> TcM Type
-                      -> TcM ([TcTyVar], Type)
-tcImplicitTKBndrsType var_ns thing_inside
-  = tcImplicitTKBndrs var_ns $
-    do { res_ty <- thing_inside
-       ; return (res_ty, allBoundVariables res_ty) }
-
--- this more general variant is needed in tcHsPatSigType.
--- See Note [Pattern signature binders]
-tcImplicitTKBndrsX :: (Name -> TcM (TcTyVar, Bool))  -- new_tv function
+--------------------------------------
+-- Implicit binders
+--------------------------------------
+
+-- | Bring implicitly quantified type/kind variables into scope during
+-- kind checking. Uses TyVarTvs, as per Note [Use TyVarTvs in kind-checking pass]
+-- in TcTyClsDecls.
+kcImplicitTKBndrs :: [Name]     -- of the vars
+                  -> TcM a
+                  -> TcM ([TcTyVar], a)  -- returns the tyvars created
+                                         -- these are *not* dependency ordered
+kcImplicitTKBndrs var_ns thing_inside
+  = do { tkvs <- mapM newFlexiKindedTyVarTyVar var_ns
+       ; result <- tcExtendTyVarEnv tkvs thing_inside
+       ; return (tkvs, result) }
+
+
+tcImplicitTKBndrs, tcImplicitTKBndrsSig, tcImplicitQTKBndrs
+  :: SkolemInfo
+  -> [Name]
+  -> TcM a
+  -> TcM ([TcTyVar], a)
+tcImplicitTKBndrs    = tcImplicitTKBndrsX newFlexiKindedSkolemTyVar
+tcImplicitTKBndrsSig = tcImplicitTKBndrsX newFlexiKindedTyVarTyVar
+tcImplicitQTKBndrs   = tcImplicitTKBndrsX newFlexiKindedQTyVar
+
+tcImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
+                   -> SkolemInfo
                    -> [Name]
-                   -> TcM (a, TyVarSet)
-                   -> TcM ([TcTyVar], a)
--- Returned TcTyVars have the supplied Names,
--- but may be in different order to the original [Name]
+                   -> TcM a
+                   -> TcM ([TcTyVar], a)   -- these tyvars are dependency-ordered
+-- * Guarantees to call solveLocalEqualities to unify
+--   all constraints from thing_inside.
+--
+-- * Returned TcTyVars have the supplied HsTyVarBndrs,
+--   but may be in different order to the original [Name]
 --   (because of sorting to respect dependency)
--- Returned TcTyVars have zonked kinds
-tcImplicitTKBndrsX new_tv var_ns thing_inside
-  = do { tkvs_pairs <- mapM new_tv var_ns
-       ; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ]
-             tkvs            = map fst tkvs_pairs
-       ; (result, bound_tvs) <- tcExtendTyVarEnv must_scope_tkvs $
-                                thing_inside
-
-         -- Check that the implicitly-bound kind variable
-         -- really can go at the beginning.
-         -- e.g.   forall (a :: k) (b :: *). ...(forces k :: b)...
-       ; tkvs <- mapM zonkTyCoVarKind tkvs
-                 -- NB: /not/ zonkTcTyVarToTyVar. tcImplicitTKBndrsX
-                 -- guarantees to return TcTyVars with the same Names
-                 -- as the var_ns.  See [Pattern signature binders]
-
-       ; let extra = text "NB: Implicitly-bound variables always come" <+>
-                     text "before other ones."
-       ; checkValidInferredKinds tkvs bound_tvs extra
-
-       ; let final_tvs = toposortTyVars tkvs
-       ; traceTc "tcImplicitTKBndrs" (ppr var_ns $$ ppr final_tvs)
+--
+-- * Returned TcTyVars have zonked kinds
+--   See Note [Keeping scoped variables in order: Implicit]
+tcImplicitTKBndrsX new_tv skol_info tv_names thing_inside
+  | null tv_names -- Short cut for the common case where there
+                  -- are no implicit type variables to bind
+  = do { result <- solveLocalEqualities thing_inside
+       ; return ([], result) }
 
+  | otherwise
+  = do { (skol_tvs, result)
+           <- solveLocalEqualities $
+              checkTvConstraints skol_info Nothing $
+              do { tkvs <- mapM new_tv tv_names
+                 ; result <- tcExtendTyVarEnv tkvs thing_inside
+                 ; return (tkvs, result) }
+
+       ; skol_tvs <- mapM zonkTcTyCoVarBndr skol_tvs
+          -- use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv
+
+          -- do a stable topological sort, following
+          -- Note [Ordering of implicit variables] in RnTypes
+       ; let final_tvs = toposortTyVars skol_tvs
+       ; traceTc "tcImplicitTKBndrs" (ppr tv_names $$ ppr final_tvs)
        ; return (final_tvs, result) }
 
-tcExplicitTKBndrs :: [LHsTyVarBndr GhcRn]
-                  -> ([TyVar] -> TcM (a, TyVarSet))
-                        -- ^ Thing inside returns the set of variables bound
-                        -- in the scope. See Note [Scope-check inferred kinds]
-                  -> TcM (a, TyVarSet)  -- ^ returns augmented bound vars
+newFlexiKindedQTyVar :: Name -> TcM TcTyVar
+-- Make a new skolem for an implicit binder in a type/class/type
+-- instance declaration, with a flexi-kind
+-- But check for in-scope-ness, and if so return that instead
+newFlexiKindedQTyVar name
+  = do { mb_tv <- tcLookupLcl_maybe name
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> newFlexiKindedSkolemTyVar name }
+
+newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
+newFlexiKindedTyVar new_tv name
+  = do { kind <- newMetaKindVar
+       ; new_tv name kind }
+
+newFlexiKindedSkolemTyVar :: Name -> TcM TyVar
+newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar
+
+newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
+newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
+
+--------------------------------------
+-- Explicit binders
+--------------------------------------
+
+-- | Used during the "kind-checking" pass in TcTyClsDecls only,
+-- and even then only for data-con declarations.
+-- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls
+kcExplicitTKBndrs :: [LHsTyVarBndr GhcRn]
+                  -> TcM a
+                  -> TcM a
+kcExplicitTKBndrs [] thing_inside = thing_inside
+kcExplicitTKBndrs (L _ hs_tv : hs_tvs) thing_inside
+  = do { tv <- tcHsTyVarBndr newTyVarTyVar hs_tv
+       ; tcExtendTyVarEnv [tv] $
+         kcExplicitTKBndrs hs_tvs thing_inside }
+
+tcExplicitTKBndrs :: SkolemInfo
+                  -> [LHsTyVarBndr GhcRn]
+                  -> TcM a
+                  -> TcM ([TcTyVar], a)
+tcExplicitTKBndrs skol_info hs_tvs thing_inside
+-- Used for the forall'd binders in type signatures of various kinds:
+--     - function signatures
+--     - data con signatures in GADT-style decls
+--     - pattern synonym signatures
+--     - expression type signatures
+--
+-- Specifically NOT used for the binders of a data type
+-- or type family decl. So the forall'd variables always /shadow/
+-- anything already in scope, and the complications of
+-- tcHsQTyVarName to not apply.
+--
+-- This function brings into scope a telescope of binders as written by
+-- the user. At first blush, it would then seem that we should bring
+-- them into scope one at a time, bumping the TcLevel each time.
+-- (Recall that we bump the level to prevent skolem escape from happening.)
+-- However, this leads to terrible error messages, because we end up
+-- failing to unify with some `k0`. Better would be to allow type inference
+-- to work, potentially creating a skolem-escape problem, and then to
+-- notice that the telescope is out of order. That's what we do here,
+-- following the logic of tcImplicitTKBndrsX.
+-- See also Note [Keeping scoped variables in order: Explicit]
+--
 -- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs
-tcExplicitTKBndrs orig_hs_tvs thing_inside
-  = tcExplicitTKBndrsX newSkolemTyVar orig_hs_tvs thing_inside
-
-tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar)
-                   -> [LHsTyVarBndr GhcRn]
-                   -> ([TyVar] -> TcM (a, TyVarSet))
-                        -- ^ Thing inside returns the set of variables bound
-                        -- in the scope. See Note [Scope-check inferred kinds]
-                   -> TcM (a, TyVarSet)  -- ^ returns augmented bound vars
-tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside
-  = go orig_hs_tvs $ \ tvs ->
-    do { (result, bound_tvs) <- thing_inside tvs
-
-         -- Issue an error if the ordering is bogus.
-         -- See Note [Bad telescopes] in TcValidity.
-       ; tvs <- checkZonkValidTelescope (interppSP orig_hs_tvs) tvs empty
-       ; checkValidInferredKinds tvs bound_tvs empty
+  | null hs_tvs  -- Short cut that avoids creating an implication
+                 -- constraint in the common case where none is needed
+  = do { result <- thing_inside
+       ; return ([], result) }
+
+  | otherwise
+  = do { (skol_tvs, result) <- checkTvConstraints skol_info (Just doc) $
+                               bind_tvbs hs_tvs
 
        ; traceTc "tcExplicitTKBndrs" $
-           vcat [ text "Hs vars:" <+> ppr orig_hs_tvs
-                , text "tvs:" <+> sep (map pprTyVar tvs) ]
+           vcat [ text "Hs vars:" <+> ppr hs_tvs
+                , text "tvs:" <+> pprTyVars skol_tvs ]
+
+       ; return (skol_tvs, result) }
 
-       ; return (result, bound_tvs `unionVarSet` mkVarSet tvs)
-       }
   where
-    go [] thing = thing []
-    go (L _ hs_tv : hs_tvs) thing
-      = do { tv <- tcHsTyVarBndr new_tv hs_tv
+    bind_tvbs [] = do { result <- thing_inside
+                      ; return ([], result) }
+    bind_tvbs (L _ tvb : tvbs)
+      = do { tv <- tcHsTyVarBndr newSkolemTyVar tvb
            ; tcExtendTyVarEnv [tv] $
-             go hs_tvs $ \ tvs ->
-             thing (tv : tvs) }
+        do { (tvs, result) <- bind_tvbs tvbs
+           ; return (tv : tvs, result) }}
 
+    doc = sep (map ppr hs_tvs)
+
+-----------------
 tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
               -> HsTyVarBndr GhcRn -> TcM TcTyVar
--- Return a SkolemTv TcTyVar, initialised with a kind variable.
+-- Return a TcTyVar, built using the provided function
 -- Typically the Kind inside the HsTyVarBndr will be a tyvar
 -- with a mutable kind in it.
--- NB: These variables must not be in scope. This function
--- is not appropriate for use with associated types, for example.
 --
 -- Returned TcTyVar has the same name; no cloning
---
--- See also Note [Associated type tyvar names] in Class
---
-tcHsTyVarBndr new_tv (UserTyVar (L _ name))
-  = do { kind <- newMetaKindVar
-       ; new_tv name kind }
-
-tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)
-  = do { kind <- tcLHsKindSig kind
-       ; new_tv name kind }
+tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))
+  = newFlexiKindedTyVar new_tv tv_nm
+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; new_tv tv_nm kind }
+tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
 
+-----------------
 newWildTyVar :: Name -> TcM TcTyVar
 -- ^ New unification variable for a wildcard
 newWildTyVar _name
@@ -1563,54 +1865,71 @@ newWildTyVar _name
        ; uniq <- newUnique
        ; details <- newMetaDetails TauTv
        ; let name = mkSysTvName uniq (fsLit "w")
-       ; return (mkTcTyVar name kind details) }
-
--- | Produce a tyvar of the given name (with the kind provided, or
--- otherwise a meta-var kind). If
--- the name is already in scope, return the scoped variable, checking
--- to make sure the known kind matches any kind provided. The
--- second return value says whether the variable is in scope (True)
--- or not (False). (Use this for associated types, for example.)
-tcHsTyVarName :: Maybe Kind -> Name -> TcM (TcTyVar, Bool)
-tcHsTyVarName m_kind name
-  = do { mb_tv <- tcLookupLcl_maybe name
-       ; case mb_tv of
-           Just (ATyVar _ tv)
-             -> do { whenIsJust m_kind $ \ kind ->
-                     discardResult $
-                     unifyKind (Just (mkTyVarTy tv)) kind (tyVarKind tv)
-                   ; return (tv, True) }
-           _ -> do { kind <- case m_kind of
-                               Just kind -> return kind
-                               Nothing   -> newMetaKindVar
-                   ; tv <- newSkolemTyVar name kind
-                   ; return (tv, False) }}
-
--- makes a new skolem tv
-newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
-newSkolemTyVar name kind = do { lvl <- getTcLevel
-                              ; return (mk_skolem_tv lvl name kind) }
-
-mk_skolem_tv :: TcLevel -> Name -> Kind -> TcTyVar
-mk_skolem_tv lvl n k = mkTcTyVar n k (SkolemTv lvl False)
+             tyvar = (mkTcTyVar name kind details)
+       ; traceTc "newWildTyVar" (ppr tyvar)
+       ; return tyvar }
 
-------------------
-kindGeneralizeType :: Type -> TcM Type
--- Result is zonked
-kindGeneralizeType ty
-  = do { kvs <- kindGeneralize ty
-       ; ty <- zonkSigType (mkInvForAllTys kvs ty)
-       ; return ty  }
+--------------------------
+-- Bringing tyvars into scope
+--------------------------
+
+-- | Bring tyvars into scope, wrapping the thing_inside in an implication
+-- constraint. The implication constraint is necessary to provide SkolemInfo
+-- for the tyvars and to ensure that no unification variables made outside
+-- the scope of these tyvars (i.e. lower TcLevel) unify with the locally-scoped
+-- tyvars (i.e. higher TcLevel).
+--
+-- INVARIANT: The thing_inside must check only types, never terms.
+--
+-- Use this (not tcExtendTyVarEnv) wherever you expect a Λ or ∀ in Core.
+-- Use tcExtendTyVarEnv otherwise.
+scopeTyVars :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a
+scopeTyVars skol_info tvs = scopeTyVars2 skol_info [(tyVarName tv, tv) | tv <- tvs]
+
+-- | Like 'scopeTyVars', but allows you to specify different scoped names
+-- than the Names stored within the tyvars.
+scopeTyVars2 :: SkolemInfo -> [(Name, TcTyVar)] -> TcM a -> TcM a
+scopeTyVars2 skol_info prs thing_inside
+  = fmap snd $ -- discard the TcEvBinds, which will always be empty
+    checkConstraints skol_info (map snd prs) [{- no EvVars -}] $
+    tcExtendNameTyVarEnv prs $
+    thing_inside
 
+------------------
 kindGeneralize :: TcType -> TcM [KindVar]
 -- Quantify the free kind variables of a kind or type
 -- In the latter case the type is closed, so it has no free
 -- type variables.  So in both cases, all the free vars are kind vars
-kindGeneralize kind_or_type
-  = do { kvs <- zonkTcTypeAndFV kind_or_type
+-- Input needn't be zonked.
+-- NB: You must call solveEqualities or solveLocalEqualities before
+-- kind generalization
+kindGeneralize = kindGeneralizeLocal emptyWC
+
+-- | This variant of 'kindGeneralize' refuses to generalize over any
+-- variables free in the given WantedConstraints. Instead, it promotes
+-- these variables into an outer TcLevel. See also
+-- Note [Promoting unification variables] in TcSimplify
+kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]
+kindGeneralizeLocal wanted kind_or_type
+  = do {
+       -- This bit is very much like decideMonoTyVars in TcSimplify,
+       -- but constraints are so much simpler in kinds, it is much
+       -- easier here. (In particular, we never quantify over a
+       -- constraint in a type.)
+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)
+       ; (_, constrained) <- promoteTyVarSet constrained
+
+         -- NB: zonk here, after promotion
+       ; kvs <- zonkTcTypeAndFV kind_or_type
        ; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet }
+
        ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
-       ; quantifyTyVars gbl_tvs dvs }
+       ; traceTc "kindGeneralizeLocal" (vcat [ ppr wanted
+                                             , ppr kind_or_type
+                                             , ppr constrained
+                                             , ppr dvs ])
+
+       ; quantifyTyVars (gbl_tvs `unionVarSet` constrained) dvs }
 
 {-
 Note [Kind generalisation]
@@ -1660,16 +1979,16 @@ Consider
   data T = MkT (forall (a :: k). Proxy a)
   -- from test ghci/scripts/T7873
 
-This is not an existential datatype, but a higher-rank one. Note that
-the forall to the right of MkT. Also consider
+This is not an existential datatype, but a higher-rank one (the forall
+to the right of MkT). Also consider
 
   data S a = MkS (Proxy (a :: k))
 
-According to the rules around implicitly-bound kind variables, those
-k's scope over the whole declarations. The renamer grabs it and adds it
-to the hsq_implicits field of the HsQTyVars of the tycon. So it must
-be in scope during type-checking, but we want to reject T while accepting
-S.
+According to the rules around implicitly-bound kind variables, in both
+cases those k's scope over the whole declaration. The renamer grabs
+it and adds it to the hsq_implicits field of the HsQTyVars of the
+tycon. So it must be in scope during type-checking, but we want to
+reject T while accepting S.
 
 Why reject T? Because the kind variable isn't fixed by anything. For
 a variable like k to be implicit, it needs to be mentioned in the kind
@@ -1687,9 +2006,49 @@ we check to make sure that k has been unified with some other variable
 it must be a free-floating kind var. Error.
 
 CUSK: When we determine the tycon's final, never-to-be-changed kind
-in kcHsTyVarBndrs, we check to make sure all implicitly-bound kind
+in kcLHsQTyVars, we check to make sure all implicitly-bound kind
 vars are indeed mentioned in a kind somewhere. If not, error.
 
+We also perform free-floating kind var analysis for type family instances
+(see #13985). Here is an interesting example:
+
+    type family   T :: k
+    type instance T = (Nothing :: Maybe a)
+
+Upon a cursory glance, it may appear that the kind variable `a` is
+free-floating above, since there are no (visible) LHS patterns in `T`. However,
+there is an *invisible* pattern due to the return kind, so inside of GHC, the
+instance looks closer to this:
+
+    type family T @k :: k
+    type instance T @(Maybe a) = (Nothing :: Maybe a)
+
+Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
+fact not free-floating. Contrast that with this example:
+
+    type instance T = Proxy (Nothing :: Maybe a)
+
+This would looks like this inside of GHC:
+
+    type instance T @(*) = Proxy (Nothing :: Maybe a)
+
+So this time, `a` is neither bound by a visible nor invisible type pattern on
+the LHS, so it would be reported as free-floating.
+
+Finally, here's one more brain-teaser (from #9574). In the example below:
+
+    class Funct f where
+      type Codomain f :: *
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+
+As it turns out, `o` is not free-floating in this example. That is because `o`
+bound by the kind signature of the LHS type pattern 'KProxy. To make this more
+obvious, one can also write the instance like so:
+
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
+
 -}
 
 --------------------
@@ -1710,8 +2069,9 @@ kcLookupTcTyCon nm
 -- Never emits constraints, though the thing_inside might.
 kcTyClTyVars :: Name -> TcM a -> TcM a
 kcTyClTyVars tycon_name thing_inside
+  -- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls
   = do { tycon <- kcLookupTcTyCon tycon_name
-       ; tcExtendTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside }
+       ; tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside }
 
 tcTyClTyVars :: Name
              -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
@@ -1734,59 +2094,144 @@ tcTyClTyVars :: Name
 tcTyClTyVars tycon_name thing_inside
   = do { tycon <- kcLookupTcTyCon tycon_name
 
-       ; let scoped_tvs = tcTyConScopedTyVars tycon
-               -- these are all zonked:
-             binders    = tyConBinders tycon
-             res_kind   = tyConResKind tycon
+       -- Do checks on scoped tyvars
+       -- See Note [Free-floating kind vars]
+       ; let flav = tyConFlavour tycon
+             scoped_prs = tcTyConScopedTyVars tycon
+             scoped_tvs = map snd scoped_prs
+             still_sig_tvs = filter isTyVarTyVar scoped_tvs
 
-          -- See Note [Free-floating kind vars]
-       ; zonked_scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs
-       ; let still_sig_tvs = filter isSigTyVar zonked_scoped_tvs
-       ; checkNoErrs $ reportFloatingKvs tycon_name (tyConFlavour tycon)
-                                         zonked_scoped_tvs still_sig_tvs
+       ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_prs)
 
-          -- Add the *unzonked* tyvars to the env't, because those
-          -- are the ones mentioned in the source.
-       ; tcExtendTyVarEnv scoped_tvs $
+       ; checkNoErrs $ reportFloatingKvs tycon_name flav
+                                         scoped_tvs still_sig_tvs
+
+       ; let res_kind   = tyConResKind tycon
+             binders    = correct_binders (tyConBinders tycon) res_kind
+       ; traceTc "tcTyClTyVars" (ppr tycon_name <+> ppr binders)
+       ; scopeTyVars2 (TyConSkol flav tycon_name) scoped_prs $
          thing_inside binders res_kind }
+  where
+    report_sig_tv_err (n1, n2)
+      = setSrcSpan (getSrcSpan n2) $
+        addErrTc (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+
+    -- Given some TyConBinders and a TyCon's result kind, make sure that the
+    -- correct any wrong Named/Anon choices. For example, consider
+    --   type Syn k = forall (a :: k). Proxy a
+    -- At first, it looks like k should be named -- after all, it appears on the RHS.
+    -- However, the correct kind for Syn is (* -> *).
+    -- (Why? Because k is the kind of a type, so k's kind is *. And the RHS also has
+    -- kind *.) See also #13963.
+    correct_binders :: [TyConBinder] -> Kind -> [TyConBinder]
+    correct_binders binders kind
+      = binders'
+      where
+        (_, binders') = mapAccumR go (tyCoVarsOfType kind) binders
+
+        go :: TyCoVarSet -> TyConBinder -> (TyCoVarSet, TyConBinder)
+        go fvs binder
+          | isNamedTyConBinder binder
+          , not (tv `elemVarSet` fvs)
+          = (new_fvs, mkAnonTyConBinder tv)
+
+          | not (isNamedTyConBinder binder)
+          , tv `elemVarSet` fvs
+          = (new_fvs, mkNamedTyConBinder Required tv)
+             -- always Required, because it was anonymous (i.e. visible) previously
+
+          | otherwise
+          = (new_fvs, binder)
+
+          where
+            tv      = binderVar binder
+            new_fvs = fvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)
 
 -----------------------------------
-tcDataKindSig :: Kind -> TcM ([TyConBinder], Kind)
+tcDataKindSig :: [TyConBinder]
+              -> Kind
+              -> TcM ([TyConBinder], Kind)
 -- GADT decls can have a (perhaps partial) kind signature
---      e.g.  data T :: * -> * -> * where ...
--- This function makes up suitable (kinded) type variables for
--- the argument kinds, and checks that the result kind is indeed *.
--- We use it also to make up argument type variables for for data instances.
+--      e.g.  data T a :: * -> * -> * where ...
+-- This function makes up suitable (kinded) TyConBinders for the
+-- argument kinds.  E.g. in this case it might return
+--   ([b::*, c::*], *)
 -- Never emits constraints.
--- Returns the new TyVars, the extracted TyBinders, and the new, reduced
--- result kind (which should always be Type or a synonym thereof)
-tcDataKindSig kind
-  = do  { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
-        ; span <- getSrcSpanM
-        ; us   <- newUniqueSupply
+-- It's a little trickier than you might think: see
+-- Note [TyConBinders for the result kind signature of a data type]
+tcDataKindSig tc_bndrs kind
+  = do  { loc     <- getSrcSpanM
+        ; uniqs   <- newUniqueSupply
         ; rdr_env <- getLocalRdrEnv
-        ; let uniqs = uniqsFromSupply us
-              occs  = [ occ | str <- allNameStrings
-                            , let occ = mkOccName tvName str
-                            , isNothing (lookupLocalRdrOcc rdr_env occ) ]
-                 -- Note [Avoid name clashes for associated data types]
-
-    -- NB: Use the tv from a binder if there is one. Otherwise,
-    -- we end up inventing a new Unique for it, and any other tv
-    -- that mentions the first ends up with the wrong kind.
-              extra_bndrs = zipWith4 mkTyBinderTyConBinder
-                              tv_bndrs (repeat span) uniqs occs
-
-        ; return (extra_bndrs, res_kind) }
+        ; let new_occs = [ occ
+                         | str <- allNameStrings
+                         , let occ = mkOccName tvName str
+                         , isNothing (lookupLocalRdrOcc rdr_env occ)
+                         -- Note [Avoid name clashes for associated data types]
+                         , not (occ `elem` lhs_occs) ]
+              new_uniqs = uniqsFromSupply uniqs
+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))
+        ; return (go loc new_occs new_uniqs subst [] kind) }
   where
-    (tv_bndrs, res_kind) = splitPiTys kind
-
-badKindSig :: Kind -> SDoc
-badKindSig kind
- = hang (text "Kind signature on data type declaration has non-* return kind")
+    lhs_tvs  = map binderVar tc_bndrs
+    lhs_occs = map getOccName lhs_tvs
+
+    go loc occs uniqs subst acc kind
+      = case splitPiTy_maybe kind of
+          Nothing -> (reverse acc, substTy subst kind)
+
+          Just (Anon arg, kind')
+            -> go loc occs' uniqs' subst' (tcb : acc) kind'
+            where
+              arg'   = substTy subst arg
+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'
+              subst' = extendTCvInScope subst tv
+              tcb    = Bndr tv AnonTCB
+              (uniq:uniqs') = uniqs
+              (occ:occs')   = occs
+
+          Just (Named (Bndr tv vis), kind')
+            -> go loc occs uniqs subst' (tcb : acc) kind'
+            where
+              (subst', tv') = substTyVarBndr subst tv
+              tcb = Bndr tv' (NamedTCB vis)
+
+badKindSig :: Bool -> Kind -> SDoc
+badKindSig check_for_type kind
+ = hang (sep [ text "Kind signature on data type declaration has non-*"
+             , (if check_for_type then empty else text "and non-variable") <+>
+               text "return kind" ])
         2 (ppr kind)
 
-{-
+{- Note [TyConBinders for the result kind signature of a data type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+  data T (a::*) :: * -> forall k. k -> *
+we want to generate the extra TyConBinders for T, so we finally get
+  (a::*) (b::*) (k::*) (c::k)
+The function tcDataKindSig generates these extra TyConBinders from
+the result kind signature.
+
+We need to take care to give the TyConBinders
+  (a) OccNames that are fresh (because the TyConBinders of a TyCon
+      must have distinct OccNames
+
+  (b) Uniques that are fresh (obviously)
+
+For (a) we need to avoid clashes with the tyvars declared by
+the user before the "::"; in the above example that is 'a'.
+And also see Note [Avoid name clashes for associated data types].
+
+For (b) suppose we have
+   data T :: forall k. k -> forall k. k -> *
+where the two k's are identical even up to their uniques.  Surprisingly,
+this can happen: see Trac #14515.
+
+It's reasonably easy to solve all this; just run down the list with a
+substitution; hence the recursive 'go' function.  But it has to be
+done.
+
 Note [Avoid name clashes for associated data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider    class C a b where
@@ -1806,7 +2251,7 @@ It isn't essential for correctness.
 
 ************************************************************************
 *                                                                      *
-             Partial signatures and pattern signatures
+             Partial signatures
 *                                                                      *
 ************************************************************************
 
@@ -1816,60 +2261,124 @@ tcHsPartialSigType
   :: UserTypeCtxt
   -> LHsSigWcType GhcRn       -- The type signature
   -> TcM ( [(Name, TcTyVar)]  -- Wildcards
-         , Maybe TcTyVar      -- Extra-constraints wildcard
-         , [TcTyVar]          -- Implicitly and explicitly bound type variables
+         , Maybe TcType       -- Extra-constraints wildcard
+         , [Name]             -- Original tyvar names, in correspondence with ...
+         , [TcTyVar]          -- ... Implicitly and explicitly bound type variables
          , TcThetaType        -- Theta part
          , TcType )           -- Tau part
+-- See Note [Recipe for checking a signature]
 tcHsPartialSigType ctxt sig_ty
-  | HsWC { hswc_wcs  = sig_wcs,         hswc_body = ib_ty } <- sig_ty
-  , HsIB { hsib_vars = implicit_hs_tvs, hsib_body = hs_ty } <- ib_ty
+  | HsWC { hswc_ext  = sig_wcs,         hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = implicit_hs_tvs
+         , hsib_body = hs_ty } <- ib_ty
   , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
   = addSigCtxt ctxt hs_ty $
-    do { (implicit_tvs, (wcs, wcx, explicit_tvs, theta, tau))
-            <- tcWildCardBindersX newWildTyVar sig_wcs        $ \ wcs ->
-               tcImplicitTKBndrsX new_implicit_tv implicit_hs_tvs $
-               tcExplicitTKBndrsX newSigTyVar explicit_hs_tvs $ \ explicit_tvs ->
+    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
+            <- tcWildCardBinders sig_wcs $ \ wcs ->
+               tcImplicitTKBndrsSig skol_info implicit_hs_tvs      $
+               tcExplicitTKBndrs    skol_info explicit_hs_tvs      $
                do {   -- Instantiate the type-class context; but if there
                       -- is an extra-constraints wildcard, just discard it here
                     (theta, wcx) <- tcPartialContext hs_ctxt
 
                   ; tau <- tcHsOpenType hs_tau
 
-                  ; let bound_tvs = unionVarSets [ allBoundVariables tau
-                                                 , mkVarSet explicit_tvs
-                                                 , mkVarSet (map snd wcs) ]
-
-                  ; return ( (wcs, wcx, explicit_tvs, theta, tau)
-                           , bound_tvs) }
-
-        ; emitWildCardHoleConstraints wcs
-
-        ; explicit_tvs <- mapM zonkTyCoVarKind explicit_tvs
-        ; let all_tvs = implicit_tvs ++ explicit_tvs
-                        -- The implicit_tvs already have zonked kinds
-
-        ; theta   <- mapM zonkTcType theta
-        ; tau     <- zonkTcType tau
-        ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
-
-        ; traceTc "tcHsPartialSigType" (ppr all_tvs)
-        ; return (wcs, wcx, all_tvs, theta, tau) }
+                  ; return (wcs, wcx, theta, tau) }
+
+         -- We must return these separately, because all the zonking below
+         -- might change the name of a TyVarTv. This, in turn, causes trouble
+         -- in partial type signatures that bind scoped type variables, as
+         -- we bring the wrong name into scope in the function body.
+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug
+       ; let tv_names = map tyVarName (implicit_tvs ++ explicit_tvs)
+
+       -- Spit out the wildcards (including the extra-constraints one)
+       -- as "hole" constraints, so that they'll be reported if necessary
+       -- See Note [Extra-constraint holes in partial type signatures]
+       ; emitWildCardHoleConstraints wcs
+
+         -- The TyVarTvs created above will sometimes have too high a TcLevel
+         -- (note that they are generated *after* bumping the level in
+         -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level
+         -- is still important here, because the kinds of these variables
+         -- do indeed need to have the higher level, so they can unify
+         -- with other local type variables. But, now that we've type-checked
+         -- everything (and solved equalities in the tcImplicit call)
+         -- we need to promote the TyVarTvs so we don't violate the TcLevel
+         -- invariant
+       ; all_tvs <- mapM zonkPromoteTyCoVarBndr (implicit_tvs ++ explicit_tvs)
+            -- zonkPromoteTyCoVarBndr deals well with TyVarTvs
+
+       ; theta   <- mapM zonkPromoteType theta
+       ; tau     <- zonkPromoteType tau
+
+       ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
+
+       ; traceTc "tcHsPartialSigType" (ppr all_tvs)
+       ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }
   where
-    new_implicit_tv name = do { kind <- newMetaKindVar
-                              ; tv <- newSigTyVar name kind
-                              ; return (tv, False) }
+    skol_info   = SigTypeSkol ctxt
+tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"
+tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"
 
-tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcTyVar)
+tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
 tcPartialContext hs_theta
   | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
   , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
-  = do { wc_tv <- tcWildCardOcc wc constraintKind
+  = do { wc_tv_ty <- tcWildCardOcc wc constraintKind
        ; theta <- mapM tcLHsPredType hs_theta1
-       ; return (theta, Just wc_tv) }
+       ; return (theta, Just wc_tv_ty) }
   | otherwise
   = do { theta <- mapM tcLHsPredType hs_theta
        ; return (theta, Nothing) }
 
+{- Note [Extra-constraint holes in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: (_) => a -> a
+  f x = ...
+
+* The renamer makes a wildcard name for the "_", and puts it in
+  the hswc_wcs field.
+
+* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
+  tcWildCardBinders.
+
+* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar
+  with the inferred constraints, e.g. (Eq a, Show a)
+
+* TcErrors.mkHoleError finally reports the error.
+
+An annoying difficulty happens if there are more than 62 inferred
+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.
+Where do we find the TyCon?  For good reasons we only have constraint
+tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how
+can we make a 70-tuple?  This was the root cause of Trac #14217.
+
+It's incredibly tiresome, because we only need this type to fill
+in the hole, to communicate to the error reporting machinery.  Nothing
+more.  So I use a HACK:
+
+* I make an /ordinary/ tuple of the constraints, in
+  TcBinds.chooseInferredQuantifiers. This is ill-kinded because
+  ordinary tuples can't contain constraints, but it works fine. And for
+  ordinary tuples we don't have the same limit as for constraint
+  tuples (which need selectors and an assocated class).
+
+* Because it is ill-kinded, it trips an assert in writeMetaTyVar,
+  so now I disable the assertion if we are writing a type of
+  kind Constraint.  (That seldom/never normally happens so we aren't
+  losing much.)
+
+Result works fine, but it may eventually bite us.
+
+
+************************************************************************
+*                                                                      *
+      Pattern signatures (i.e signatures that occur in patterns)
+*                                                                      *
+********************************************************************* -}
+
 tcHsPatSigType :: UserTypeCtxt
                -> LHsSigWcType GhcRn          -- The type signature
                -> TcM ( [(Name, TcTyVar)]     -- Wildcards
@@ -1881,43 +2390,50 @@ tcHsPatSigType :: UserTypeCtxt
 -- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x
 --
 -- This may emit constraints
-
+-- See Note [Recipe for checking a signature]
 tcHsPatSigType ctxt sig_ty
-  | HsWC { hswc_wcs = sig_wcs,   hswc_body = ib_ty } <- sig_ty
-  , HsIB { hsib_vars = sig_vars, hsib_body = hs_ty } <- ib_ty
+  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = sig_vars
+         , hsib_body = hs_ty } <- ib_ty
   = addSigCtxt ctxt hs_ty $
-    do { (implicit_tvs, (wcs, sig_ty))
-            <- tcWildCardBindersX newWildTyVar    sig_wcs  $ \ wcs ->
-               tcImplicitTKBndrsX new_implicit_tv sig_vars $
+    do { sig_tkvs <- mapM new_implicit_tv sig_vars
+       ; (wcs, sig_ty)
+            <- tcWildCardBinders sig_wcs  $ \ wcs ->
+               tcExtendTyVarEnv sig_tkvs                           $
                do { sig_ty <- tcHsOpenType hs_ty
-                  ; return ((wcs, sig_ty), allBoundVariables sig_ty) }
+                  ; return (wcs, sig_ty) }
 
         ; emitWildCardHoleConstraints wcs
 
-        ; sig_ty <- zonkTcType sig_ty
+          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty
+          -- contains a forall). Promote these.
+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...
+          -- When we instantiate x, we have to compare the kind of the argument
+          -- to a's kind, which will be a metavariable.
+        ; sig_ty <- zonkPromoteType sig_ty
         ; checkValidType ctxt sig_ty
 
-        ; tv_pairs <- mapM mk_tv_pair implicit_tvs
+        ; tv_pairs <- mapM mk_tv_pair sig_tkvs
 
         ; traceTc "tcHsPatSigType" (ppr sig_vars)
         ; return (wcs, tv_pairs, sig_ty) }
   where
     new_implicit_tv name = do { kind <- newMetaKindVar
-                              ; tv <- new_tv name kind
-                              ; return (tv, False) }
-       -- "False" means that these tyvars aren't yet in scope
+                              ; new_tv name kind }
+
     new_tv = case ctxt of
                RuleSigCtxt {} -> newSkolemTyVar
-               _              -> newSigTyVar
+               _              -> newTauTyVar
       -- See Note [Pattern signature binders]
-      -- See Note [Unifying SigTvs]
 
     mk_tv_pair tv = do { tv' <- zonkTcTyVarToTyVar tv
                        ; return (tyVarName tv, tv') }
          -- The Name is one of sig_vars, the lexically scoped name
-         -- But if it's a SigTyVar, it might have been unified
+         -- But if it's a TyVarTv, it might have been unified
          -- with an existing in-scope skolem, so we must zonk
          -- here.  See Note [Pattern signature binders]
+tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"
+tcHsPatSigType _ (XHsWildCardBndrs _) = panic "tcHsPatSigType"
 
 tcPatSig :: Bool                    -- True <=> pattern binding
          -> LHsSigWcType GhcRn
@@ -1956,7 +2472,7 @@ tcPatSig in_pat_bind sig res_ty
                 -- Here 'a' doesn't get a binding.  Sigh
         ; let bad_tvs = [ tv | (_,tv) <- sig_tvs
                              , not (tv `elemVarSet` exactTyCoVarsOfType sig_ty) ]
-        ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
+        ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)
 
         -- Now do a subsumption check of the pattern signature against res_ty
         ; wrap <- addErrCtxtM (mk_msg sig_ty) $
@@ -1985,24 +2501,31 @@ patBindSigErr sig_tvs
 {- Note [Pattern signature binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
-   data T = forall a. T a (a->Int)
-   f (T x (f :: b->Int)) = blah
+
+  data T where
+    MkT :: forall a. a -> (a -> Int) -> T
+
+  f :: T -> ...
+  f (MkT x (f :: b -> c)) = ...
 
 Here
- * The pattern (T p1 p2) creates a *skolem* type variable 'a_sk',
+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',
    It must be a skolem so that that it retains its identity, and
    TcErrors.getSkolemInfo can thereby find the binding site for the skolem.
 
- * The type signature pattern (f :: b->Int) makes a fresh meta-tyvar b_sig
-   (a SigTv), and binds "b" :-> b_sig in the envt
+ * The type signature pattern (f :: b -> c) makes freshs meta-tyvars
+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the
+   environment
 
- * Then unification makes b_sig := a_sk
-   That's why we must make b_sig a MetaTv (albeit a SigTv),
-   not a SkolemTv, so that it can unify to a_sk.
+ * Then unification makes beta := a_sk, gamma := Int
+   That's why we must make beta and gamma a MetaTv,
+   not a SkolemTv, so that it can unify to a_sk rsp. Int.
+   Note that gamma unifies with a type, not just a type variable
+   (see https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0029-scoped-type-variables-types.rst)
 
- * Finally, in 'blah' we must have the envt "b" :-> a_sk.  The pair
-   ("b" :-> a_sk) is returned by tcHsPatSigType, constructed by
-   mk_tv_pair in that funcion.
+ * Finally, in 'blah' we must have the envt "b" :-> a_sk, "c" :-> Int.
+   The pairs ("b" :-> a_sk, "c" :-> Int) are returned by tcHsPatSigType,
+   constructed by mk_tv_pair in that function.
 
 Another example (Trac #13881):
    fl :: forall (l :: [a]). Sing l -> Sing l
@@ -2011,7 +2534,7 @@ When we reach the pattern signature, 'l' is in scope from the
 outer 'forall':
    "a" :-> a_sk :: *
    "l" :-> l_sk :: [a_sk]
-We make up a fresh meta-SigTv, y_sig, for 'y', and kind-check
+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check
 the pattern signature
    Sing (l :: [y])
 That unifies y_sig := a_sk.  We return from tcHsPatSigType with
@@ -2023,23 +2546,6 @@ Here this really is the binding site of the type variable so we'd like
 to use a skolem, so that we get a complaint if we unify two of them
 together.
 
-Note [Unifying SigTvs]
-~~~~~~~~~~~~~~~~~~~~~~
-ALAS we have no decent way of avoiding two SigTvs getting unified.
-Consider
-  f (x::(a,b)) (y::c)) = [fst x, y]
-Here we'd really like to complain that 'a' and 'c' are unified. But
-for the reasons above we can't make a,b,c into skolems, so they
-are just SigTvs that can unify.  And indeed, this would be ok,
-  f x (y::c) = case x of
-                 (x1 :: a1, True) -> [x,y]
-                 (x1 :: a2, False) -> [x,y,y]
-Here the type of x's first component is called 'a1' in one branch and
-'a2' in the other.  We could try insisting on the same OccName, but
-they definitely won't have the sane lexical Name.
-
-I think we could solve this by recording in a SigTv a list of all the
-in-scope variables that it should not unify with, but it's fiddly.
 
 
 ************************************************************************
@@ -2050,16 +2556,93 @@ in-scope variables that it should not unify with, but it's fiddly.
 
 -}
 
-unifyKinds :: [(TcType, TcKind)] -> TcM ([TcType], TcKind)
-unifyKinds act_kinds
+unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
+unifyKinds rn_tys act_kinds
   = do { kind <- newMetaKindVar
-       ; let check (ty, act_kind) = checkExpectedKind ty act_kind kind
-       ; tys' <- mapM check act_kinds
+       ; let check rn_ty (ty, act_kind) = checkExpectedKind (unLoc rn_ty) ty act_kind kind
+       ; tys' <- zipWithM check rn_tys act_kinds
        ; return (tys', kind) }
 
 {-
 ************************************************************************
 *                                                                      *
+    Promotion
+*                                                                      *
+************************************************************************
+-}
+
+-- | Whenever a type is about to be added to the environment, it's necessary
+-- to make sure that any free meta-tyvars in the type are promoted to the
+-- current TcLevel. (They might be at a higher level due to the level-bumping
+-- in tcExplicitTKBndrs, for example.) This function both zonks *and*
+-- promotes. Why at the same time? See Note [Recipe for checking a signature]
+zonkPromoteType :: TcType -> TcM TcType
+zonkPromoteType = mapType zonkPromoteMapper ()
+
+-- cf. TcMType.zonkTcTypeMapper
+zonkPromoteMapper :: TyCoMapper () TcM
+zonkPromoteMapper = TyCoMapper { tcm_smart    = True
+                               , tcm_tyvar    = const zonkPromoteTcTyVar
+                               , tcm_covar    = const covar
+                               , tcm_hole     = const hole
+                               , tcm_tycobinder = const tybinder
+                               , tcm_tycon    = return }
+  where
+    covar cv
+      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv
+
+    hole :: CoercionHole -> TcM Coercion
+    hole h
+      = do { contents <- unpackCoercionHole_maybe h
+           ; case contents of
+               Just co -> do { co <- zonkPromoteCoercion co
+                             ; checkCoercionHole cv co }
+               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv
+                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }
+      where
+        cv = coHoleCoVar h
+
+    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)
+    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTcTyVar :: TyCoVar -> TcM TcType
+zonkPromoteTcTyVar tv
+  | isMetaTyVar tv
+  = do { let ref = metaTyVarRef tv
+       ; contents <- readTcRef ref
+       ; case contents of
+           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv
+                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }
+           Indirect ty -> zonkPromoteType ty }
+
+  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars
+  = do { tc_lvl <- getTcLevel
+       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }
+
+  | otherwise
+  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType
+
+zonkPromoteTyCoVarBndr :: TyCoVar -> TcM TyCoVar
+zonkPromoteTyCoVarBndr tv
+  | isTyVarTyVar tv
+  = tcGetTyVar "zonkPromoteTyCoVarBndr TyVarTv" <$> zonkPromoteTcTyVar tv
+
+  | isTcTyVar tv && isSkolemTyVar tv
+  = do { tc_lvl <- getTcLevel
+       ; zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }
+
+  | otherwise
+  = zonkPromoteTyCoVarKind tv
+
+zonkPromoteCoercion :: Coercion -> TcM Coercion
+zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()
+
+{-
+************************************************************************
+*                                                                      *
         Sort checking kinds
 *                                                                      *
 ************************************************************************
@@ -2068,10 +2651,15 @@ tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
 It does sort checking and desugaring at the same time, in one single pass.
 -}
 
-tcLHsKindSig :: LHsKind GhcRn -> TcM Kind
-tcLHsKindSig hs_kind
-  = do { kind <- tc_lhs_kind kindLevelMode hs_kind
-       ; zonkTcType kind }
+tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
+tcLHsKindSig ctxt hs_kind
+-- See  Note [Recipe for checking a signature] in TcHsType
+-- Result is zonked
+  = do { kind <- solveLocalEqualities $
+                 tc_lhs_kind kindLevelMode hs_kind
+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
+       -- No generalization, so we must promote
+       ; kind <- zonkPromoteType kind
          -- This zonk is very important in the case of higher rank kinds
          -- E.g. Trac #13879    f :: forall (p :: forall z (y::z). <blah>).
          --                          <more blah>
@@ -2079,6 +2667,10 @@ tcLHsKindSig hs_kind
          --      it's crucial that the kind we instantiate is fully zonked,
          --      else we may fail to substitute properly
 
+       ; checkValidType ctxt kind
+       ; traceTc "tcLHsKindSig2" (ppr kind)
+       ; return kind }
+
 tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind
 tc_lhs_kind mode k
   = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $
@@ -2090,12 +2682,15 @@ promotionErr name err
                    2 (parens reason))
   where
     reason = case err of
+               ConstrainedDataConPE pred
+                              -> text "it has an unpromotable context"
+                                 <+> quotes (ppr pred)
                FamDataConPE   -> text "it comes from a data family instance"
-               NoDataKindsTC  -> text "Perhaps you intended to use DataKinds"
-               NoDataKindsDC  -> text "Perhaps you intended to use DataKinds"
-               NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType"
-               NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType"
-               PatSynPE       -> text "Pattern synonyms cannot be promoted"
+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"
+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"
+               PatSynPE       -> text "pattern synonyms cannot be promoted"
+               PatSynExPE     -> sep [ text "the existential variables of a pattern synonym"
+                                     , text "signature do not scope over the pattern" ]
                _ -> text "it is defined and used in the same recursive group"
 
 {-
@@ -2106,8 +2701,8 @@ promotionErr name err
 ************************************************************************
 -}
 
-badPatSigTvs :: TcType -> [TyVar] -> SDoc
-badPatSigTvs sig_ty bad_tvs
+badPatTyVarTvs :: TcType -> [TyVar] -> SDoc
+badPatTyVarTvs sig_ty bad_tvs
   = vcat [ fsep [text "The type variable" <> plural bad_tvs,
                  quotes (pprWithCommas ppr bad_tvs),
                  text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),
@@ -2142,23 +2737,31 @@ reportFloatingKvs tycon_name flav all_tvs bad_tvs
     do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs
        ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs
        ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs
-             tidy_bad_tvs             = map (tidyTyVarOcc tidy_env) bad_tvs
-       ; typeintype <- xoptM LangExt.TypeInType
-       ; mapM_ (report typeintype tidy_all_tvs) tidy_bad_tvs }
+             tidy_bad_tvs             = map (tidyTyCoVarOcc tidy_env) bad_tvs
+       ; mapM_ (report tidy_all_tvs) tidy_bad_tvs }
   where
-    report typeintype tidy_all_tvs tidy_bad_tv
+    report tidy_all_tvs tidy_bad_tv
       = addErr $
         vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+>
                text "is implicitly bound in" <+> ppr flav
              , quotes (ppr tycon_name) <> comma <+>
                text "but does not appear as the kind of any"
              , text "of its type variables. Perhaps you meant"
-             , text "to bind it" <+> ppWhen (not typeintype)
-                                            (text "(with TypeInType)") <+>
-                                 text "explicitly somewhere?"
+             , text "to bind it explicitly somewhere?"
              , ppWhen (not (null tidy_all_tvs)) $
                  hang (text "Type variables with inferred kinds:")
                  2 (ppr_tv_bndrs tidy_all_tvs) ]
 
     ppr_tv_bndrs tvs = sep (map pp_tv tvs)
     pp_tv tv         = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))
+
+-- | If the inner action emits constraints, reports them as errors and fails;
+-- otherwise, propagates the return value. Useful as a wrapper around
+-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be
+-- another chance to solve constraints
+failIfEmitsConstraints :: TcM a -> TcM a
+failIfEmitsConstraints thing_inside
+  = do { (res, lie) <- captureConstraints thing_inside
+       ; reportAllUnsolved lie
+       ; return res
+       }
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 022668b470..d69357a0e2 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -14,17 +14,19 @@ module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import TcBinds
 import TcTyClsDecls
+import TcTyDecls ( addTyConsToGblEnv )
 import TcClassDcl( tcClassDecl2, tcATDefault,
                    HsSigFun, mkHsSigFun,
                    findMethodBind, instantiateMethod )
 import TcSigs
 import TcRnMonad
 import TcValidity
-import TcHsSyn    ( zonkTyBndrsX, emptyZonkEnv
-                  , zonkTcTypeToTypes, zonkTcTypeToType )
+import TcHsSyn
 import TcMType
 import TcType
 import BuildTyCl
@@ -49,14 +51,13 @@ import Class
 import Var
 import VarEnv
 import VarSet
-import PrelNames  ( typeableClassName, genericClassNames
-                  , knownNatClassName, knownSymbolClassName )
 import Bag
 import BasicTypes
 import DynFlags
 import ErrUtils
 import FastString
 import Id
+import ListSetOps
 import MkId
 import Name
 import NameSet
@@ -412,13 +413,12 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a
 --        (b) the type envt with stuff from data type decls
 addFamInsts fam_insts thing_inside
   = tcExtendLocalFamInstEnv fam_insts $
-    tcExtendGlobalEnv axioms $
-    tcExtendTyConEnv data_rep_tycons  $
+    tcExtendGlobalEnv axioms          $
     do { traceTc "addFamInsts" (pprFamInsts fam_insts)
-       ; tcg_env <- tcAddImplicits data_rep_tycons
-                    -- Does not add its axiom; that comes from
-                    -- adding the 'axioms' above
-       ; setGblEnv tcg_env thing_inside }
+       ; gbl_env <- addTyConsToGblEnv data_rep_tycons
+                    -- Does not add its axiom; that comes
+                    -- from adding the 'axioms' above
+       ; setGblEnv gbl_env thing_inside }
   where
     axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
     data_rep_tycons = famInstsRepTyCons fam_insts
@@ -460,6 +460,8 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
   = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
        ; return (insts, fam_insts, deriv_infos) }
 
+tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"
+
 tcClsInstDecl :: LClsInstDecl GhcRn
               -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
 -- The returned DerivInfos are for any associated data families
@@ -469,16 +471,19 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                   , cid_datafam_insts = adts }))
   = setSrcSpan loc                      $
     addErrCtxt (instDeclCtxt1 poly_ty)  $
-    do  { (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty
+    do  { (tyvars, theta, clas, inst_tys)
+             <- tcHsClsInstType (InstDeclCtxt False) poly_ty
+             -- NB: tcHsClsInstType does checkValidInstance
+
         ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
               mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
               mb_info    = Just (clas, tyvars, mini_env)
 
         -- Next, process any associated types.
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
-        ; tyfam_insts0  <- tcExtendTyVarEnv tyvars $
+        ; tyfam_insts0  <- scopeTyVars InstSkol tyvars $
                            mapAndRecoverM (tcTyFamInstDecl mb_info) ats
-        ; datafam_stuff <- tcExtendTyVarEnv tyvars $
+        ; datafam_stuff <- scopeTyVars InstSkol tyvars $
                            mapAndRecoverM (tcDataFamInstDecl mb_info) adts
         ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff
               deriv_infos                    = catMaybes m_deriv_infos
@@ -487,8 +492,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         -- from their defaults (if available)
         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
                             `unionNameSet`
-                            mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
-        ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats)
+                            mkNameSet (map (unLoc . feqn_tycon
+                                                  . hsib_body
+                                                  . dfid_eqn
+                                                  . unLoc) adts)
+        ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
                                (classATItems clas)
 
         -- Finally, construct the Core representation of the instance.
@@ -507,59 +515,14 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                                      , ib_extensions = []
                                      , ib_derived = False } }
 
-        ; doClsInstErrorChecks inst_info
+         -- In hs-boot files there should be no bindings
+        ; is_boot <- tcIsHsBootOrSig
+        ; let no_binds = isEmptyLHsBinds binds && null uprags
+        ; failIfTc (is_boot && not no_binds) badBootDeclErr
 
         ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
                  , deriv_infos ) }
-
-
-doClsInstErrorChecks :: InstInfo GhcRn -> TcM ()
-doClsInstErrorChecks inst_info
- = do { traceTc "doClsInstErrorChecks" (ppr ispec)
-      ; dflags <- getDynFlags
-      ; is_boot <- tcIsHsBootOrSig
-
-         -- In hs-boot files there should be no bindings
-      ; failIfTc (is_boot && not no_binds) badBootDeclErr
-
-         -- If not in an hs-boot file, abstract classes cannot have
-         -- instances declared
-      ; failIfTc (not is_boot && isAbstractClass clas) abstractClassInstErr
-
-         -- Handwritten instances of any rejected
-         -- class is always forbidden
-         -- #12837
-      ; failIfTc (clas_nm `elem` rejectedClassNames) clas_err
-
-         -- Check for hand-written Generic instances (disallowed in Safe Haskell)
-      ; when (clas_nm `elem` genericClassNames) $
-        do { failIfTc (safeLanguageOn dflags) gen_inst_err
-           ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
-  }
-  where
-    ispec    = iSpec inst_info
-    binds    = iBinds inst_info
-    no_binds = isEmptyLHsBinds (ib_binds binds) && null (ib_pragmas binds)
-    clas_nm  = is_cls_nm ispec
-    clas     = is_cls ispec
-
-    gen_inst_err = hang (text ("Generic instances can only be "
-                            ++ "derived in Safe Haskell.") $+$
-                         text "Replace the following instance:")
-                      2 (pprInstanceHdr ispec)
-
-    abstractClassInstErr =
-        text "Cannot define instance for abstract class" <+> quotes (ppr clas_nm)
-
-    -- Report an error or a warning for certain class instances.
-    -- If we are working on an .hs-boot file, we just report a warning,
-    -- and ignore the instance.  We do this, to give users a chance to fix
-    -- their code.
-    rejectedClassNames = [ typeableClassName
-                         , knownNatClassName
-                         , knownSymbolClassName ]
-    clas_err = text "Class" <+> quotes (ppr clas_nm)
-                    <+> text "does not support user-specified instances"
+tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
 
 {-
 ************************************************************************
@@ -600,7 +563,7 @@ tcTyFamInstDecl :: Maybe ClsInstInfo
 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
   = setSrcSpan loc           $
     tcAddTyFamInstCtxt decl  $
-    do { let fam_lname = tfe_tycon (unLoc eqn)
+    do { let fam_lname = feqn_tycon (hsib_body eqn)
        ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
 
          -- (0) Check it's an open type family
@@ -609,7 +572,8 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
        ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
 
          -- (1) do the work of verifying the synonym group
-       ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn
+       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
+                                        (L (getLoc fam_lname) eqn)
 
          -- (2) check for validity
        ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
@@ -623,12 +587,17 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
                   -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
   -- "newtype instance" and "data instance"
 tcDataFamInstDecl mb_clsinfo
-    (L loc decl@(DataFamInstDecl
-       { dfid_pats = pats
-       , dfid_tycon = fam_tc_name
-       , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
-                                     , dd_ctxt = ctxt, dd_cons = cons
-                                     , dd_derivs = derivs } }))
+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
+                                                   , hsib_body =
+      FamEqn { feqn_pats   = pats
+             , feqn_tycon  = fam_tc_name
+             , feqn_fixity = fixity
+             , feqn_rhs    = HsDataDefn { dd_ND = new_or_data
+                                        , dd_cType = cType
+                                        , dd_ctxt = ctxt
+                                        , dd_cons = cons
+                                        , dd_kindSig = m_ksig
+                                        , dd_derivs = derivs } }}}))
   = setSrcSpan loc             $
     tcAddDataFamInstCtxt decl  $
     do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
@@ -638,16 +607,17 @@ tcDataFamInstDecl mb_clsinfo
        ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
          -- Kind check type patterns
-       ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
-                     (kcDataDefn (unLoc fam_tc_name) pats defn) $
+       ; let mb_kind_env = thdOf3 <$> mb_clsinfo
+       ; tcFamTyPats fam_tc mb_clsinfo tv_names pats
+                     (kcDataDefn mb_kind_env decl) $
              \tvs pats res_kind ->
     do { stupid_theta <- solveEqualities $ tcHsContext ctxt
 
             -- Zonk the patterns etc into the Type world
-       ; (ze, tvs')    <- zonkTyBndrsX emptyZonkEnv tvs
-       ; pats'         <- zonkTcTypeToTypes ze pats
-       ; res_kind'     <- zonkTcTypeToType  ze res_kind
-       ; stupid_theta' <- zonkTcTypeToTypes ze stupid_theta
+       ; (ze, tvs')    <- zonkTyBndrs tvs
+       ; pats'         <- zonkTcTypesToTypesX ze pats
+       ; res_kind'     <- zonkTcTypeToTypeX   ze res_kind
+       ; stupid_theta' <- zonkTcTypesToTypesX ze stupid_theta
 
        ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons
 
@@ -657,15 +627,25 @@ tcDataFamInstDecl mb_clsinfo
 
        ; let (eta_pats, etad_tvs) = eta_reduce pats'
              eta_tvs              = filterOut (`elem` etad_tvs) tvs'
-             full_tvs             = eta_tvs ++ etad_tvs
+                 -- NB: the "extra" tvs from tcDataKindSig would always be eta-reduced
+
+             full_tcbs = mkTyConBindersPreferAnon (eta_tvs ++ etad_tvs) res_kind'
                  -- Put the eta-removed tyvars at the end
                  -- Remember, tvs' is in arbitrary order (except kind vars are
                  -- first, so there is no reason to suppose that the etad_tvs
                  -- (obtained from the pats) are at the end (Trac #11148)
-             orig_res_ty          = mkTyConApp fam_tc pats'
+
+         -- Deal with any kind signature.
+         -- See also Note [Arity of data families] in FamInstEnv
+       ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind'
+       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind')
+
+       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs
+             all_pats    = pats' `chkAppend` extra_pats
+             orig_res_ty = mkTyConApp fam_tc all_pats
 
        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { let ty_binders = mkTyConBindersPreferAnon full_tvs liftedTypeKind
+           do { let ty_binders = full_tcbs `chkAppend` extra_tcbs
               ; data_cons <- tcConDecls rec_rep_tc
                                         (ty_binders, orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
@@ -676,14 +656,14 @@ tcDataFamInstDecl mb_clsinfo
               ; let axiom  = mkSingleCoAxiom Representational
                                              axiom_name eta_tvs [] fam_tc eta_pats
                                              (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
-                    parent = DataFamInstTyCon axiom fam_tc pats'
+                    parent = DataFamInstTyCon axiom fam_tc all_pats
 
 
-                      -- NB: Use the full_tvs from the pats. See bullet toward
+                      -- NB: Use the full ty_binders from the pats. See bullet toward
                       -- the end of Note [Data type families] in TyCon
                     rep_tc   = mkAlgTyCon rep_tc_name
                                           ty_binders liftedTypeKind
-                                          (map (const Nominal) full_tvs)
+                                          (map (const Nominal) ty_binders)
                                           (fmap unLoc cType) stupid_theta
                                           tc_rhs parent
                                           gadt_syntax
@@ -697,10 +677,10 @@ tcDataFamInstDecl mb_clsinfo
          -- Remember to check validity; no recursion to worry about here
          -- Check that left-hand sides are ok (mono-types, no type families,
          -- consistent instantiations, etc)
-       ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats'
+       ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats
 
          -- Result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind res_kind') $
+       ; checkTc (tcIsLiftedTypeKind final_res_kind) $
          tooFewParmsErr (tyConArity fam_tc)
 
        ; checkValidTyCon rep_tc
@@ -730,6 +710,17 @@ tcDataFamInstDecl mb_clsinfo
       = go pats (tv : etad_tvs)
     go pats etad_tvs = (reverse pats, etad_tvs)
 
+    pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig
+
+tcDataFamInstDecl _
+    (L _ (DataFamInstDecl
+         { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn _ }}}))
+  = panic "tcDataFamInstDecl"
+tcDataFamInstDecl _ (L _ (DataFamInstDecl (XHsImplicitBndrs _)))
+  = panic "tcDataFamInstDecl"
+tcDataFamInstDecl _ (L _ (DataFamInstDecl (HsIB _ (XFamEqn _))))
+  = panic "tcDataFamInstDecl"
+
 
 {- *********************************************************************
 *                                                                      *
@@ -819,17 +810,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                             , sc_binds   `unionBags` meth_binds
                             , sc_implics `unionBags` meth_implics ) }
 
-       ; env <- getLclEnv
-       ; emitImplication $ Implic { ic_tclvl  = tclvl
-                                  , ic_skols  = inst_tyvars
-                                  , ic_no_eqs = False
-                                  , ic_given  = dfun_ev_vars
-                                  , ic_wanted = mkImplicWC sc_meth_implics
-                                  , ic_status = IC_Unsolved
-                                  , ic_binds  = dfun_ev_binds_var
-                                  , ic_needed = emptyVarSet
-                                  , ic_env    = env
-                                  , ic_info   = InstSkol }
+       ; imp <- newImplication
+       ; emitImplication $
+         imp { ic_tclvl  = tclvl
+             , ic_skols  = inst_tyvars
+             , ic_given  = dfun_ev_vars
+             , ic_wanted = mkImplicWC sc_meth_implics
+             , ic_binds  = dfun_ev_binds_var
+             , ic_info   = InstSkol }
 
        -- Create the result bindings
        ; self_dict <- newDict clas inst_tys
@@ -847,14 +835,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                      --    con_app_scs  = MkD ty1 ty2 sc1 sc2
                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
              con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)
-                                     (HsConLikeOut (RealDataCon dict_constr))
+                                  (HsConLikeOut noExt (RealDataCon dict_constr))
                        -- NB: We *can* have covars in inst_tys, in the case of
                        -- promoted GADT constructors.
 
-             con_app_args = foldl app_to_meth con_app_tys sc_meth_ids
+             con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
 
              app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
-             app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
+             app_to_meth fun meth_id = HsApp noExt (L loc fun)
+                                            (L loc (wrapId arg_wrapper meth_id))
 
              inst_tv_tys = mkTyVarTys inst_tyvars
              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
@@ -867,16 +856,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                     -- Newtype dfuns just inline unconditionally,
                     -- so don't attempt to specialise them
 
-             export = ABE { abe_wrap = idHsWrapper
+             export = ABE { abe_ext  = noExt
+                          , abe_wrap = idHsWrapper
                           , abe_poly = dfun_id_w_prags
                           , abe_mono = self_dict
                           , abe_prags = dfun_spec_prags }
                           -- NB: see Note [SPECIALISE instance pragmas]
-             main_bind = AbsBinds { abs_tvs = inst_tyvars
+             main_bind = AbsBinds { abs_ext = noExt
+                                  , abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
                                   , abs_ev_binds = []
-                                  , abs_binds = unitBag dict_bind }
+                                  , abs_binds = unitBag dict_bind
+                                  , abs_sig = True }
 
        ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
        }
@@ -916,8 +908,8 @@ addDFunPrags dfun_id sc_meth_ids
    [dict_con]  = tyConDataCons clas_tc
    is_newtype  = isNewTyCon clas_tc
 
-wrapId :: HsWrapper -> IdP id -> HsExpr id
-wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id))
+wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
 
 {- Note [Typechecking plan for instance declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -966,7 +958,7 @@ Notice that
    into *every* method or superclass definition.  (Some of it will
    be usused in some, but dead-code elimination will drop it.)
 
-   We achieve this by putting the the evidence variable for the overall
+   We achieve this by putting the evidence variable for the overall
    instance implication into the AbsBinds for each method/superclass.
    Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
    (And that in turn is why the abs_ev_binds field of AbBinds is a
@@ -1015,16 +1007,19 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
            ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
            ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
                  sc_top_id = mkLocalId sc_top_name sc_top_ty
-                 export = ABE { abe_wrap = idHsWrapper
+                 export = ABE { abe_ext  = noExt
+                              , abe_wrap = idHsWrapper
                               , abe_poly = sc_top_id
                               , abe_mono = sc_ev_id
                               , abe_prags = noSpecPrags }
                  local_ev_binds = TcEvBinds ev_binds_var
-                 bind = AbsBinds { abs_tvs      = tyvars
+                 bind = AbsBinds { abs_ext      = noExt
+                                 , abs_tvs      = tyvars
                                  , abs_ev_vars  = dfun_evs
                                  , abs_exports  = [export]
                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                 , abs_binds    = emptyBag }
+                                 , abs_binds    = emptyBag
+                                 , abs_sig      = False }
            ; return (sc_top_id, L loc bind, sc_implic) }
 
 -------------------
@@ -1036,19 +1031,13 @@ checkInstConstraints thing_inside
                                     thing_inside
 
        ; ev_binds_var <- newTcEvBinds
-       ; env <- getLclEnv
-       ; let implic = Implic { ic_tclvl  = tclvl
-                             , ic_skols  = []
-                             , ic_no_eqs = False
-                             , ic_given  = []
-                             , ic_wanted = wanted
-                             , ic_status = IC_Unsolved
-                             , ic_binds  = ev_binds_var
-                             , ic_needed = emptyVarSet
-                             , ic_env    = env
-                             , ic_info   = InstSkol }
-
-       ; return (implic, ev_binds_var, result) }
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = InstSkol }
+
+       ; return (implic', ev_binds_var, result) }
 
 {-
 Note [Recursive superclasses]
@@ -1171,7 +1160,7 @@ Answer:
 
   * When we make a superclass selection from InstSkol we use
     a SkolemInfo of (InstSC size), where 'size' is the size of
-    the constraint whose superclass we are taking.  An similarly
+    the constraint whose superclass we are taking.  A similarly
     when taking the superclass of an InstSC.  This is implemented
     in TcCanonical.newSCWorkFromFlavored
 
@@ -1263,17 +1252,27 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                                 , ib_pragmas    = sigs
                                 , ib_extensions = exts
                                 , ib_derived    = is_derived })
-  = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
+      -- tcExtendTyVarEnv (not scopeTyVars) is OK because the TcLevel is pushed
+      -- in checkInstConstraints
+  = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
        -- The lexical_tvs scope over the 'where' part
     do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
        ; checkMinimalDefinition
+       ; checkMethBindMembership
        ; (ids, binds, mb_implics) <- set_exts exts $
+                                     unset_warnings_deriving $
                                      mapAndUnzip3M tc_item op_items
        ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
   where
     set_exts :: [LangExt.Extension] -> TcM a -> TcM a
     set_exts es thing = foldr setXOptM thing es
 
+    -- See Note [Avoid -Winaccessible-code when deriving]
+    unset_warnings_deriving :: TcM a -> TcM a
+    unset_warnings_deriving
+      | is_derived = unsetWOptM Opt_WarnInaccessibleCode
+      | otherwise  = id
+
     hs_sig_fn = mkHsSigFun sigs
     inst_loc  = getSrcSpan dfun_id
 
@@ -1309,13 +1308,12 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                              mkLHsWrap lam_wrapper (error_rhs dflags)
            ; return (meth_id, meth_bind, Nothing) }
       where
-        error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
+        error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
         error_fun    = L inst_loc $
                        wrapId (mkWpTyApps
-                                [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau
-                                , meth_tau])
+                                [ getRuntimeRep meth_tau, meth_tau])
                               nO_METHOD_BINDING_ERROR_ID
-        error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText
+        error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
                                               (unsafeMkByteString (error_string dflags))))
         meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)
         error_string dflags = showSDoc dflags
@@ -1330,6 +1328,90 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     methodExists meth = isJust (findMethodBind meth binds prag_fn)
 
+    ----------------------
+    -- Check if any method bindings do not correspond to the class.
+    -- See Note [Mismatched class methods and associated type families].
+    checkMethBindMembership
+      = let bind_nms         = map unLoc $ collectMethodBinders binds
+            cls_meth_nms     = map (idName . fst) op_items
+            mismatched_meths = bind_nms `minusList` cls_meth_nms
+        in forM_ mismatched_meths $ \mismatched_meth ->
+             addErrTc $ hsep
+             [ text "Class", quotes (ppr (className clas))
+             , text "does not have a method", quotes (ppr mismatched_meth)]
+
+{-
+Note [Mismatched class methods and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's entirely possible for someone to put methods or associated type family
+instances inside of a class in which it doesn't belong. For instance, we'd
+want to fail if someone wrote this:
+
+  instance Eq () where
+    type Rep () = Maybe
+    compare = undefined
+
+Since neither the type family `Rep` nor the method `compare` belong to the
+class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
+since that would discover that the parent class `Eq` is incorrect.
+
+However, there is a scenario in which the renamer could fail to catch this:
+if the instance was generated through Template Haskell, as in #12387. In that
+case, Template Haskell will provide fully resolved names (e.g.,
+`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
+on. For this reason, we also put an extra validity check for this in the
+typechecker as a last resort.
+
+Note [Avoid -Winaccessible-code when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Winaccessible-code can be particularly noisy when deriving instances for
+GADTs. Consider the following example (adapted from #8128):
+
+  data T a where
+    MkT1 :: Int -> T Int
+    MkT2 :: T Bool
+    MkT3 :: T Bool
+  deriving instance Eq (T a)
+  deriving instance Ord (T a)
+
+In the derived Ord instance, GHC will generate the following code:
+
+  instance Ord (T a) where
+    compare x y
+      = case x of
+          MkT2
+            -> case y of
+                 MkT1 {} -> GT
+                 MkT2    -> EQ
+                 _       -> LT
+          ...
+
+However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
+differ, so if -Winaccessible-code is enabled, then deriving this instance will
+result in unwelcome warnings.
+
+One conceivable approach to fixing this issue would be to change `deriving Ord`
+such that it becomes smarter about not generating unreachable cases. This,
+however, would be a highly nontrivial refactor, as we'd have to propagate
+through typing information everywhere in the algorithm that generates Ord
+instances in order to determine which cases were unreachable. This seems like
+a lot of work for minimal gain, so we have opted not to go for this approach.
+
+Instead, we take the much simpler approach of always disabling
+-Winaccessible-code for derived code. To accomplish this, we do the following:
+
+1. In tcMethods (which typechecks method bindings), disable
+   -Winaccessible-code.
+2. When creating Implications during typechecking, record the Env
+   (through ic_env) at the time of creation. Since the Env also stores
+   DynFlags, this will remember that -Winaccessible-code was disabled over
+   the scope of that implication.
+3. After typechecking comes error reporting, where GHC must decide how to
+   report inaccessible code to the user, on an Implication-by-Implication
+   basis. If an Implication's DynFlags indicate that -Winaccessible-code was
+   disabled, then don't bother reporting it. That's it!
+-}
+
 ------------------------
 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
              -> TcEvBinds -> Bool
@@ -1361,17 +1443,20 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
        ; spec_prags     <- tcSpecPrags global_meth_id prags
 
         ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
-              export = ABE { abe_poly      = global_meth_id
-                           , abe_mono      = local_meth_id
-                           , abe_wrap      = idHsWrapper
-                           , abe_prags     = specs }
+              export = ABE { abe_ext   = noExt
+                           , abe_poly  = global_meth_id
+                           , abe_mono  = local_meth_id
+                           , abe_wrap  = idHsWrapper
+                           , abe_prags = specs }
 
               local_ev_binds = TcEvBinds ev_binds_var
-              full_bind = AbsBinds { abs_tvs      = tyvars
+              full_bind = AbsBinds { abs_ext      = noExt
+                                   , abs_tvs      = tyvars
                                    , abs_ev_vars  = dfun_ev_vars
                                    , abs_exports  = [export]
                                    , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                   , abs_binds    = tc_bind }
+                                   , abs_binds    = tc_bind
+                                   , abs_sig      = True }
 
         ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
   where
@@ -1408,15 +1493,17 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
 
        ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
 
-       ; let export = ABE { abe_poly  = local_meth_id
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = local_meth_id
                           , abe_mono  = inner_id
                           , abe_wrap  = hs_wrap
                           , abe_prags = noSpecPrags }
 
        ; return (unitBag $ L (getLoc meth_bind) $
-                 AbsBinds { abs_tvs = [], abs_ev_vars = []
+                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
                           , abs_exports = [export]
-                          , abs_binds = tc_bind, abs_ev_binds = [] }) }
+                          , abs_binds = tc_bind, abs_ev_binds = []
+                          , abs_sig = True }) }
 
   | otherwise  -- No instance signature
   = do { let ctxt = FunSigCtxt sel_name False
@@ -1520,7 +1607,7 @@ Wow!  Three nested AbsBinds!
  * The middle one is only present if there is an instance signature,
    and does the impedance matching for that signature
  * The inner one is for the method binding itself against either the
-   signature from the class, or the the instance signature.
+   signature from the class, or the instance signature.
 -}
 
 ----------------------
@@ -1559,7 +1646,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
         ; dm_id <- tcLookupId dm_name
         ; let inline_prag = idInlinePragma dm_id
               inline_prags | isAnyInlinePragma inline_prag
-                           = [noLoc (InlineSig fn inline_prag)]
+                           = [noLoc (InlineSig noExt fn inline_prag)]
                            | otherwise
                            = []
                  -- Copy the inline pragma (if any) from the default method
@@ -1568,7 +1655,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
               fn   = noLoc (idName sel_id)
               visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
                                       , tyConBinderArgFlag tcb /= Inferred ]
-              rhs  = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
+              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
               bind = noLoc $ mkTopFunBind Generated fn $
                              [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
 
@@ -1579,8 +1666,8 @@ mkDefMethBind clas inst_tys sel_id dm_name
        ; return (bind, inline_prags) }
   where
     mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
-    mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs
-                                          $ nlHsParTy $ noLoc $ HsCoreTy ty))
+    mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
+                                      $ noLoc $ XHsType $ NHsCoreTy ty) fun)
        -- NB: use visible type application
        -- See Note [Default methods in instances]
 
@@ -1646,7 +1733,7 @@ generic default methods.
 Note [INLINE and default methods]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Default methods need special case.  They are supposed to behave rather like
-macros.  For exmample
+macros.  For example
 
   class Foo a where
     op1, op2 :: Bool -> a -> a
@@ -1782,7 +1869,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
 
 ------------------------------
 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
-tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
+tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
   = addErrCtxt (spec_ctxt prag) $
     do  { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
         ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 83dc10cae4..1771e19849 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -3,47 +3,33 @@
 module TcInteract (
      solveSimpleGivens,   -- Solves [Ct]
      solveSimpleWanteds,  -- Solves Cts
-
-     solveCallStack,      -- for use in TcSimplify
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
 import BasicTypes ( SwapFlag(..), isSwapped,
                     infinity, IntWithInf, intGtLimit )
-import HsTypes ( HsIPName(..) )
 import TcCanonical
 import TcFlatten
 import TcUnify( canSolveByUnification )
 import VarSet
 import Type
-import Kind( isConstraintKind )
-import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
+import InstEnv( DFunInstType )
 import CoAxiom( sfInteractTop, sfInteractInert )
 
-import TcMType (newMetaTyVars)
-
 import Var
 import TcType
-import Name
-import RdrName ( lookupGRE_FieldLabel )
-import PrelNames ( knownNatClassName, knownSymbolClassName,
-                   typeableClassName, coercibleTyConKey,
-                   hasFieldClassName,
-                   heqTyConKey, ipClassKey )
-import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
-                    coercibleDataCon, constraintKindTyCon )
-import TysPrim    ( eqPrimTyCon, eqReprPrimTyCon )
-import Id( idType, isNaughtyRecordSelector )
+import PrelNames ( coercibleTyConKey,
+                   heqTyConKey, eqTyConKey, ipClassKey )
 import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
 import Class
 import TyCon
-import DataCon( dataConWrapId )
-import FieldLabel
 import FunDeps
 import FamInst
+import ClsInst( ClsInstResult(..), InstanceWhat(..), safeOverlap )
 import FamInstEnv
-import Unify ( tcUnifyTyWithTFs )
+import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
 
 import TcEvidence
 import Outputable
@@ -51,7 +37,7 @@ import Outputable
 import TcRnTypes
 import TcSMonad
 import Bag
-import MonadUtils ( concatMapM )
+import MonadUtils ( concatMapM, foldlM )
 
 import Data.List( partition, foldl', deleteFirstsBy )
 import SrcLoc
@@ -201,16 +187,15 @@ solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
 -- Try solving these constraints
 -- Affects the unification state (of course) but not the inert set
 -- The result is not necessarily zonked
-solve_simple_wanteds (WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 })
+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 })
   = nestTcS $
     do { solveSimples simples1
-       ; (implics2, tv_eqs, fun_eqs, insols2, others) <- getUnsolvedInerts
+       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts
        ; (unif_count, unflattened_eqs) <- reportUnifications $
                                           unflattenWanteds tv_eqs fun_eqs
             -- See Note [Unflatten after solving the simple wanteds]
        ; return ( unif_count
                 , WC { wc_simple = others `andCts` unflattened_eqs
-                     , wc_insol  = insols1 `andCts` insols2
                      , wc_impl   = implics1 `unionBags` implics2 }) }
 
 {- Note [The solveSimpleWanteds loop]
@@ -260,8 +245,9 @@ runTcPluginsGiven
        ; if null givens then return [] else
     do { p <- runTcPlugins plugins (givens,[],[])
        ; let (solved_givens, _, _) = pluginSolvedCts p
+             insols                = pluginBadCts p
        ; updInertCans (removeInertCts solved_givens)
-       ; mapM_ emitInsoluble (pluginBadCts p)
+       ; updInertIrreds (\irreds -> extendCtsList irreds insols)
        ; return (pluginNewCts p) } } }
 
 -- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on
@@ -270,7 +256,7 @@ runTcPluginsGiven
 -- 'solveSimpleWanteds' should feed the updated wanteds back into the
 -- main solver.
 runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
-runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 })
+runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 })
   | isEmptyBag simples1
   = return (False, wc)
   | otherwise
@@ -284,15 +270,17 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_insol = insols1, wc_impl =
        ; let (_, _,                solved_wanted)   = pluginSolvedCts p
              (_, unsolved_derived, unsolved_wanted) = pluginInputCts p
              new_wanted                             = pluginNewCts p
+             insols                                 = pluginBadCts p
 
 -- SLPJ: I'm deeply suspicious of this
 --       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)
 
        ; mapM_ setEv solved_wanted
        ; return ( notNull (pluginNewCts p)
-                , WC { wc_simple = listToBag new_wanted `andCts` listToBag unsolved_wanted
-                                                        `andCts` listToBag unsolved_derived
-                     , wc_insol  = listToBag (pluginBadCts p) `andCts` insols1
+                , WC { wc_simple = listToBag new_wanted       `andCts`
+                                   listToBag unsolved_wanted  `andCts`
+                                   listToBag unsolved_derived `andCts`
+                                   listToBag insols
                      , wc_impl   = implics1 } ) } }
   where
     setEv :: (EvTerm,Ct) -> TcS ()
@@ -389,9 +377,11 @@ runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
 runSolverPipeline pipeline workItem
   = do { wl <- getWorkList
        ; inerts <- getTcSInerts
+       ; tclevel <- getTcLevel
        ; traceTcS "----------------------------- " empty
        ; traceTcS "Start solver pipeline {" $
-                  vcat [ text "work item =" <+> ppr workItem
+                  vcat [ text "tclevel =" <+> ppr tclevel
+                       , text "work item =" <+> ppr workItem
                        , text "inerts =" <+> ppr inerts
                        , text "rest of worklist =" <+> ppr wl ]
 
@@ -467,7 +457,7 @@ But this isn't quite true.  Suppose we have,
     c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
 After processing the first two, we get
      c1: [G] beta ~ [alpha], c2 : [W] blah
-Now, c3 does not interact with the the given c1, so when we spontaneously
+Now, c3 does not interact with the given c1, so when we spontaneously
 solve c3, we must re-react it with the inert set.  So we can attempt a
 reaction between inert c2 [W] and work-item c3 [G].
 
@@ -483,8 +473,6 @@ or, equivalently,
 
 -- Interaction result of  WorkItem <~> Ct
 
-type StopNowFlag = Bool    -- True <=> stop after this interaction
-
 interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
 -- Precondition: if the workitem is a CTyEqCan then it will not be able to
 -- react with anything at this stage.
@@ -493,94 +481,106 @@ interactWithInertsStage wi
   = do { inerts <- getTcSInerts
        ; let ics = inert_cans inerts
        ; case wi of
-             CTyEqCan    {} -> interactTyVarEq ics wi
-             CFunEqCan   {} -> interactFunEq   ics wi
-             CIrredEvCan {} -> interactIrred   ics wi
-             CDictCan    {} -> interactDict    ics wi
+             CTyEqCan  {} -> interactTyVarEq ics wi
+             CFunEqCan {} -> interactFunEq   ics wi
+             CIrredCan {} -> interactIrred   ics wi
+             CDictCan  {} -> interactDict    ics wi
              _ -> pprPanic "interactWithInerts" (ppr wi) }
                 -- CHoleCan are put straight into inert_frozen, so never get here
                 -- CNonCanonical have been canonicalised
 
 data InteractResult
-   = IRKeep      -- Keep the existing inert constraint in the inert set
-   | IRReplace   -- Replace the existing inert constraint with the work item
-   | IRDelete    -- Delete the existing inert constraint from the inert set
+   = KeepInert   -- Keep the inert item, and solve the work item from it
+                 -- (if the latter is Wanted; just discard it if not)
+   | KeepWork    -- Keep the work item, and solve the intert item from it
 
 instance Outputable InteractResult where
-  ppr IRKeep    = text "keep"
-  ppr IRReplace = text "replace"
-  ppr IRDelete  = text "delete"
+  ppr KeepInert = text "keep inert"
+  ppr KeepWork  = text "keep work-item"
 
 solveOneFromTheOther :: CtEvidence  -- Inert
                      -> CtEvidence  -- WorkItem
-                     -> TcS (InteractResult, StopNowFlag)
--- Preconditions:
--- 1) inert and work item represent evidence for the /same/ predicate
--- 2) ip/class/irred constraints only; not used for equalities
+                     -> TcS InteractResult
+-- Precondition:
+-- * inert and work item represent evidence for the /same/ predicate
+--
+-- We can always solve one from the other: even if both are wanted,
+-- although we don't rewrite wanteds with wanteds, we can combine
+-- two wanteds into one by solving one from the other
+
 solveOneFromTheOther ev_i ev_w
   | isDerived ev_w         -- Work item is Derived; just discard it
-  = return (IRKeep, True)
+  = return KeepInert
 
-  | isDerived ev_i            -- The inert item is Derived, we can just throw it away,
-  = return (IRDelete, False)  -- The ev_w is inert wrt earlier inert-set items,
-                              -- so it's safe to continue on from this point
+  | isDerived ev_i     -- The inert item is Derived, we can just throw it away,
+  = return KeepWork    -- The ev_w is inert wrt earlier inert-set items,
+                       -- so it's safe to continue on from this point
 
   | CtWanted { ctev_loc = loc_w } <- ev_w
   , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w
-  = return (IRDelete, False)
+  = -- inert must be Given
+    do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
+       ; return KeepWork }
 
-  | CtWanted { ctev_dest = dest } <- ev_w
+  | CtWanted {} <- ev_w
        -- Inert is Given or Wanted
-  = do { setWantedEvTerm dest (ctEvTerm ev_i)
-       ; return (IRKeep, True) }
+  = return KeepInert
+
+  -- From here on the work-item is Given
 
-  | CtWanted { ctev_loc = loc_i } <- ev_i   -- Work item is Given
+  | CtWanted { ctev_loc = loc_i } <- ev_i
   , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i
-  = return (IRKeep, False)  -- Just discard the un-usable Given
-                            -- This never actually happens because
-                            -- Givens get processed first
+  = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
+       ; return KeepInert }      -- Just discard the un-usable Given
+                                 -- This never actually happens because
+                                 -- Givens get processed first
 
-  | CtWanted { ctev_dest = dest } <- ev_i
-  = do { setWantedEvTerm dest (ctEvTerm ev_w)
-       ; return (IRReplace, True) }
+  | CtWanted {} <- ev_i
+  = return KeepWork
 
-  -- So they are both Given
+  -- From here on both are Given
   -- See Note [Replacement vs keeping]
+
   | lvl_i == lvl_w
-  = do { binds <- getTcEvBindsMap
-       ; return (same_level_strategy binds, True) }
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; binds <- getTcEvBindsMap ev_binds_var
+       ; return (same_level_strategy binds) }
 
   | otherwise   -- Both are Given, levels differ
-  = return (different_level_strategy, True)
+  = return different_level_strategy
   where
      pred  = ctEvPred ev_i
      loc_i = ctEvLoc ev_i
      loc_w = ctEvLoc ev_w
      lvl_i = ctLocLevel loc_i
      lvl_w = ctLocLevel loc_w
+     ev_id_i = ctEvEvId ev_i
+     ev_id_w = ctEvEvId ev_w
 
-     different_level_strategy
-       | isIPPred pred, lvl_w > lvl_i = IRReplace
-       | lvl_w < lvl_i                = IRReplace
-       | otherwise                    = IRKeep
+     different_level_strategy  -- Both Given
+       | isIPPred pred, lvl_w > lvl_i = KeepWork
+       | lvl_w < lvl_i                = KeepWork
+       | otherwise                    = KeepInert
 
-     same_level_strategy binds        -- Both Given
+     same_level_strategy binds -- Both Given
        | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
        = case ctLocOrigin loc_w of
-            GivenOrigin (InstSC s_w) | s_w < s_i -> IRReplace
-                                     | otherwise -> IRKeep
-            _                                    -> IRReplace
+            GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork
+                                     | otherwise -> KeepInert
+            _                                    -> KeepWork
 
        | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w
-       = IRKeep
+       = KeepInert
 
-       | has_binding binds ev_w
-       , not (has_binding binds ev_i)
-       = IRReplace
+       | has_binding binds ev_id_w
+       , not (has_binding binds ev_id_i)
+       , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))
+       = KeepWork
 
-       | otherwise = IRKeep
+       | otherwise
+       = KeepInert
 
-     has_binding binds ev = isJust (lookupEvBind binds (ctEvId ev))
+     has_binding binds ev_id = isJust (lookupEvBind binds ev_id)
 
 {-
 Note [Replacement vs keeping]
@@ -605,22 +605,34 @@ we keep?  More subtle than you might think!
 
   * Constraints coming from the same level (i.e. same implication)
 
-       - Always get rid of InstSC ones if possible, since they are less
-         useful for solving.  If both are InstSC, choose the one with
-         the smallest TypeSize
-         See Note [Solving superclass constraints] in TcInstDcls
+       (a) Always get rid of InstSC ones if possible, since they are less
+           useful for solving.  If both are InstSC, choose the one with
+           the smallest TypeSize
+           See Note [Solving superclass constraints] in TcInstDcls
 
-       - Keep the one that has a non-trivial evidence binding.
-            Example:  f :: (Eq a, Ord a) => blah
-            then we may find [G] d3 :: Eq a
-                             [G] d2 :: Eq a
-              with bindings  d3 = sc_sel (d1::Ord a)
+       (b) Keep the one that has a non-trivial evidence binding.
+              Example:  f :: (Eq a, Ord a) => blah
+              then we may find [G] d3 :: Eq a
+                               [G] d2 :: Eq a
+                with bindings  d3 = sc_sel (d1::Ord a)
             We want to discard d2 in favour of the superclass selection from
             the Ord dictionary.
-         Why? See Note [Tracking redundant constraints] in TcSimplify again.
-
-  * Finally, when there is still a choice, use IRKeep rather than
-    IRReplace, to avoid unnecessary munging of the inert set.
+            Why? See Note [Tracking redundant constraints] in TcSimplify again.
+
+       (c) But don't do (b) if the evidence binding depends transitively on the
+           one without a binding.  Example (with RecursiveSuperClasses)
+              class C a => D a
+              class D a => C a
+           Inert:     d1 :: C a, d2 :: D a
+           Binds:     d3 = sc_sel d2, d2 = sc_sel d1
+           Work item: d3 :: C a
+           Then it'd be ridiculous to replace d1 with d3 in the inert set!
+           Hence the findNeedEvVars test.  See Trac #14774.
+
+  * Finally, when there is still a choice, use KeepInert rather than
+    KeepWork, for two reasons:
+      - to avoid unnecessary munging of the inert set.
+      - to cut off superclass loops; see Note [Superclass loops] in TcCanonical
 
 Doing the depth-check for implicit parameters, rather than making the work item
 always override, is important.  Consider
@@ -647,6 +659,18 @@ that this chain of events won't happen, but that's very fragile.)
                    interactIrred
 *                                                                               *
 *********************************************************************************
+
+Note [Multiple matching irreds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that it's impossible to have multiple irreds all match the
+work item; after all, interactIrred looks for matches and solves one from the
+other. However, note that interacting insoluble, non-droppable irreds does not
+do this matching. We thus might end up with several insoluble, non-droppable,
+matching irreds in the inert set. When another irred comes along that we have
+not yet labeled insoluble, we can find multiple matches. These multiple matches
+cause no harm, but it would be wrong to ASSERT that they aren't there (as we
+once had done). This problem can be tickled by typecheck/should_compile/holes.
+
 -}
 
 -- Two pieces of irreducible evidence: if their types are *exactly identical*
@@ -655,31 +679,130 @@ that this chain of events won't happen, but that's very fragile.)
 -- mean that (ty1 ~ ty2)
 interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 
-interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w })
-  | let pred = ctEvPred ev_w
-        (matching_irreds, others)
-          = partitionBag (\ct -> ctPred ct `tcEqTypeNoKindCheck` pred)
-                         (inert_irreds inerts)
-  , (ct_i : rest) <- bagToList matching_irreds
-  , let ctev_i = ctEvidence ct_i
-  = ASSERT( null rest )
-    do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w
-       ; case inert_effect of
-            IRKeep    -> return ()
-            IRDelete  -> updInertIrreds (\_ -> others)
-            IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem)
-                         -- These const upd's assume that solveOneFromTheOther
-                         -- has no side effects on InertCans
-       ; if stop_now then
-            return (Stop ev_w (text "Irred equal" <+> parens (ppr inert_effect)))
-       ; else
-            continueWith workItem }
+interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })
+  | insoluble  -- For insolubles, don't allow the constaint to be dropped
+               -- which can happen with solveOneFromTheOther, so that
+               -- we get distinct error messages with -fdefer-type-errors
+               -- See Note [Do not add duplicate derived insolubles]
+  , not (isDroppableCt workItem)
+  = continueWith workItem
+
+  | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
+  , ((ct_i, swap) : _rest) <- bagToList matching_irreds
+        -- See Note [Multiple matching irreds]
+  , let ev_i = ctEvidence ct_i
+  = do { what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)
+       ; case what_next of
+            KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
+                            ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
+            KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)
+                            ; updInertIrreds (\_ -> others)
+                            ; continueWith workItem } }
 
   | otherwise
   = continueWith workItem
 
+  where
+    swap_me :: SwapFlag -> CtEvidence -> EvTerm
+    swap_me swap ev
+      = case swap of
+           NotSwapped -> ctEvTerm ev
+           IsSwapped  -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev)))
+
 interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
 
+findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)
+findMatchingIrreds irreds ev
+  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred
+    -- See Note [Solving irreducible equalities]
+  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds
+  | otherwise
+  = partitionBagWith match_non_eq irreds
+  where
+    pred = ctEvPred ev
+    match_non_eq ct
+      | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)
+      | otherwise                            = Right ct
+
+    match_eq eq_rel1 lty1 rty1 ct
+      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct)
+      , eq_rel1 == eq_rel2
+      , Just swap <- match_eq_help lty1 rty1 lty2 rty2
+      = Left (ct, swap)
+      | otherwise
+      = Right ct
+
+    match_eq_help lty1 rty1 lty2 rty2
+      | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2
+      = Just NotSwapped
+      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2
+      = Just IsSwapped
+      | otherwise
+      = Nothing
+
+{- Note [Solving irreducible equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14333)
+  [G] a b ~R# c d
+  [W] c d ~R# a b
+Clearly we should be able to solve this! Even though the constraints are
+not decomposable. We solve this when looking up the work-item in the
+irreducible constraints to look for an identical one.  When doing this
+lookup, findMatchingIrreds spots the equality case, and matches either
+way around. It has to return a swap-flag so we can generate evidence
+that is the right way round too.
+
+Note [Do not add duplicate derived insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *must* add an insoluble (Int ~ Bool) even if there is
+one such there already, because they may come from distinct call
+sites.  Not only do we want an error message for each, but with
+-fdefer-type-errors we must generate evidence for each.  But for
+*derived* insolubles, we only want to report each one once.  Why?
+
+(a) A constraint (C r s t) where r -> s, say, may generate the same fundep
+    equality many times, as the original constraint is successively rewritten.
+
+(b) Ditto the successive iterations of the main solver itself, as it traverses
+    the constraint tree. See example below.
+
+Also for *given* insolubles we may get repeated errors, as we
+repeatedly traverse the constraint tree.  These are relatively rare
+anyway, so removing duplicates seems ok.  (Alternatively we could take
+the SrcLoc into account.)
+
+Note that the test does not need to be particularly efficient because
+it is only used if the program has a type error anyway.
+
+Example of (b): assume a top-level class and instance declaration:
+
+  class D a b | a -> b
+  instance D [a] [a]
+
+Assume we have started with an implication:
+
+  forall c. Eq c => { wc_simple = D [c] c [W] }
+
+which we have simplified to:
+
+  forall c. Eq c => { wc_simple = D [c] c [W]
+                                  (c ~ [c]) [D] }
+
+For some reason, e.g. because we floated an equality somewhere else,
+we might try to re-solve this implication. If we do not do a
+dropDerivedWC, then we will end up trying to solve the following
+constraints the second time:
+
+  (D [c] c) [W]
+  (c ~ [c]) [D]
+
+which will result in two Deriveds to end up in the insoluble set:
+
+  wc_simple   = D [c] c [W]
+               (c ~ [c]) [D], (c ~ [c]) [D]
+-}
+
 {-
 *********************************************************************************
 *                                                                               *
@@ -687,8 +810,8 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
 *                                                                               *
 *********************************************************************************
 
-Note [Solving from instances when interacting Dicts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Shortcut solving]
+~~~~~~~~~~~~~~~~~~~~~~~
 When we interact a [W] constraint with a [G] constraint that solves it, there is
 a possibility that we could produce better code if instead we solved from a
 top-level instance declaration (See #12791, #5835). For example:
@@ -712,17 +835,23 @@ solution for `Num Int`. This would let us produce core like the following
           eta1
           A.f1
 
-This is bad! We could do much better if we solved [W] `Num Int` directly from
-the instance that we have in scope:
+This is bad! We could do /much/ better if we solved [W] `Num Int` directly
+from the instance that we have in scope:
 
     f :: forall b. C Int b => b -> Int -> Int
     f = \ (@ b) _ _ (x :: Int) ->
         case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }
 
-However, there is a reason why the solver does not simply try to solve such
-constraints with top-level instances. If the solver finds a relevant instance
-declaration in scope, that instance may require a context that can't be solved
-for. A good example of this is:
+** NB: It is important to emphasize that all this is purely an optimization:
+** exactly the same programs should typecheck with or without this
+** procedure.
+
+Solving fully
+~~~~~~~~~~~~~
+There is a reason why the solver does not simply try to solve such
+constraints with top-level instances. If the solver finds a relevant
+instance declaration in scope, that instance may require a context
+that can't be solved for. A good example of this is:
 
     f :: Ord [a] => ...
     f x = ..Need Eq [a]...
@@ -730,11 +859,14 @@ for. A good example of this is:
 If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
 be left with the obligation to solve the constraint Eq a, which we cannot. So we
 must be conservative in our attempt to use an instance declaration to solve the
-[W] constraint we're interested in. Our rule is that we try to solve all of the
-instance's subgoals recursively all at once. Precisely: We only attempt to
-solve constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci are
-themselves class constraints of the form `C1', ... Cm' => C' t1' ... tn'` and we
-only succeed if the entire tree of constraints is solvable from instances.
+[W] constraint we're interested in.
+
+Our rule is that we try to solve all of the instance's subgoals
+recursively all at once. Precisely: We only attempt to solve
+constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
+are themselves class constraints of the form `C1', ... Cm' => C' t1'
+... tn'` and we only succeed if the entire tree of constraints is
+solvable from instances.
 
 An example that succeeds:
 
@@ -770,6 +902,38 @@ Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:
           (m @ [a] @ b $dC eta)
           (GHC.Types.[] @ a)
 
+Note [Shortcut solving: type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have (Trac #13943)
+  class Take (n :: Nat) where ...
+  instance {-# OVERLAPPING #-}                    Take 0 where ..
+  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..
+
+And we have [W] Take 3.  That only matches one instance so we get
+[W] Take (3-1).  Really we should now flatten to reduce the (3-1) to 2, and
+so on -- but that is reproducing yet more of the solver.  Sigh.  For now,
+we just give up (remember all this is just an optimisation).
+
+But we must not just naively try to lookup (Take (3-1)) in the
+InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
+unique match on the (Take n) instance.  That leads immediately to an
+infinite loop.  Hence the check that 'preds' have no type families
+(isTyFamFree).
+
+Note [Shortcut solving: overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  instance {-# OVERLAPPABLE #-} C a where ...
+and we are typechecking
+  f :: C a => a -> a
+  f = e  -- Gives rise to [W] C a
+
+We don't want to solve the wanted constraint with the overlappable
+instance; rather we want to use the supplied (C a)! That was the whole
+point of it being overlappable!  Trac #14434 wwas an example.
+
+Note [Shortcut solving: incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This optimization relies on coherence of dictionaries to be correct. When we
 cannot assume coherence because of IncoherentInstances then this optimization
 can change the behavior of the user's code.
@@ -829,62 +993,62 @@ The output of `main` if we avoid the optimization under the effect of
 IncoherentInstances is `1`. If we were to do the optimization, the output of
 `main` would be `2`.
 
-It is important to emphasize that failure means that we don't produce more
-efficient code, NOT that we fail to typecheck at all! This is purely an
-an optimization: exactly the same programs should typecheck with or without this
-procedure.
+Note [Shortcut try_solve_from_instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The workhorse of the short-cut solver is
+    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
+                            -> CtEvidence       -- Solve this
+                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+Note that:
 
+* The CtEvidence is teh goal to be solved
+
+* The MaybeT anages early failure if we find a subgoal that
+  cannot be solved from instances.
+
+* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
+  state that allows try_solve_from_instance to augmennt the evidence
+  bindings and inert_solved_dicts as it goes.
+
+  If it succeeds, we commit all these bindings and solved dicts to the
+  main TcS InertSet.  If not, we abandon it all entirely.
+
+Passing along the solved_dicts important for two reasons:
+
+* We need to be able to handle recursive super classes. The
+  solved_dicts state  ensures that we remember what we have already
+  tried to solve to avoid looping.
+
+* As Trac #15164 showed, it can be important to exploit sharing between
+  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
+  and to solve G2 we may need H. If we don't spot this sharing we may
+  solve H twice; and if this pattern repeats we may get exponentially bad
+  behaviour.
 -}
 
 interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
-  | isWanted ev_w
-  , Just ip_name      <- isCallStackPred (ctPred workItem)
-  , OccurrenceOf func <- ctLocOrigin (ctEvLoc ev_w)
-  -- If we're given a CallStack constraint that arose from a function
-  -- call, we need to push the current call-site onto the stack instead
-  -- of solving it directly from a given.
-  -- See Note [Overview of implicit CallStacks]
-  = do { let loc = ctEvLoc ev_w
-
-         -- First we emit a new constraint that will capture the
-         -- given CallStack.
-       ; let new_loc      = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
-                            -- We change the origin to IPOccOrigin so
-                            -- this rule does not fire again.
-                            -- See Note [Overview of implicit CallStacks]
-
-       ; mb_new <- newWantedEvVar new_loc (ctEvPred ev_w)
-       ; emitWorkNC (freshGoals [mb_new])
-
-         -- Then we solve the wanted by pushing the call-site onto the
-         -- newly emitted CallStack.
-       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (getEvTerm mb_new)
-       ; solveCallStack ev_w ev_cs
-       ; stopWith ev_w "Wanted CallStack IP" }
-  | Just ctev_i <- lookupInertDict inerts cls tys
-  = do
-  { dflags <- getDynFlags
-  -- See Note [Solving from instances when interacting Dicts]
-  ; try_inst_res <- trySolveFromInstance dflags ev_w ctev_i
-  ; case try_inst_res of
-      Just evs -> do
-        { flip mapM_ evs $ \(ev_t, ct_ev, cls, typ) -> do
-          { setWantedEvBind (ctEvId ct_ev) ev_t
-          ; addSolvedDict ct_ev cls typ }
-        ; stopWith ev_w "interactDict/solved from instance" }
-      -- We were unable to solve the [W] constraint from in-scope instances so
-      -- we solve it from the solution in the inerts we just retrieved.
-      Nothing ->  do
-        { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w
-        ; case inert_effect of
-            IRKeep    -> return ()
-            IRDelete  -> updInertDicts $ \ ds -> delDict ds cls tys
-            IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem
-        ; if stop_now then
-            return $ Stop ev_w (text "Dict equal" <+> parens (ppr inert_effect))
-          else
-            continueWith workItem } }
+  | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
+  = -- There is a matching dictionary in the inert set
+    do { -- First to try to solve it /completely/ from top level instances
+         -- See Note [Shortcut solving]
+         dflags <- getDynFlags
+       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i
+       ; if short_cut_worked
+         then stopWith ev_w "interactDict/solved from instance"
+         else
+
+    do { -- Ths short-cut solver didn't fire, so we
+         -- solve ev_w from the matching inert ev_i we found
+         what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "lookupInertDict" (ppr what_next)
+       ; case what_next of
+           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
+                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
+           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
+                           ; updInertDicts $ \ ds -> delDict ds cls tys
+                           ; continueWith workItem } } }
+
   | cls `hasKey` ipClassKey
   , isGiven ev_w
   = interactGivenIP inerts workItem
@@ -895,79 +1059,98 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
 
 interactDict _ wi = pprPanic "interactDict" (ppr wi)
 
--- See Note [Solving from instances when interacting Dicts]
-trySolveFromInstance :: DynFlags
-                     -> CtEvidence -- Work item
-                     -> CtEvidence -- Inert we want to try to replace
-                     -> TcS (Maybe [(EvTerm, CtEvidence, Class, [TcPredType])])
-                     -- Everything we need to bind a solution for the work item
-                     -- and add the solved Dict to the cache in the main solver.
-trySolveFromInstance dflags ev_w ctev_i
+-- See Note [Shortcut solving]
+shortCutSolver :: DynFlags
+               -> CtEvidence -- Work item
+               -> CtEvidence -- Inert we want to try to replace
+               -> TcS Bool   -- True <=> success
+shortCutSolver dflags ev_w ev_i
   | isWanted ev_w
- && isGiven ctev_i
+ && isGiven ev_i
  -- We are about to solve a [W] constraint from a [G] constraint. We take
  -- a moment to see if we can get a better solution using an instance.
  -- Note that we only do this for the sake of performance. Exactly the same
  -- programs should typecheck regardless of whether we take this step or
- -- not. See Note [Solving from instances when interacting Dicts]
+ -- not. See Note [Shortcut solving]
+
  && not (xopt LangExt.IncoherentInstances dflags)
  -- If IncoherentInstances is on then we cannot rely on coherence of proofs
  -- in order to justify this optimization: The proof provided by the
  -- [G] constraint's superclass may be different from the top-level proof.
+ -- See Note [Shortcut solving: incoherence]
+
  && gopt Opt_SolveConstantDicts dflags
  -- Enabled by the -fsolve-constant-dicts flag
-  = runMaybeT $ try_solve_from_instance emptyDictMap ev_w
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
+                     getTcEvBindsMap ev_binds_var
+       ; solved_dicts <- getSolvedDicts
+
+       ; mb_stuff <- runMaybeT $ try_solve_from_instance
+                                   (ev_binds, solved_dicts) ev_w
 
-  | otherwise = return Nothing
+       ; case mb_stuff of
+           Nothing -> return False
+           Just (ev_binds', solved_dicts')
+              -> do { setTcEvBindsMap ev_binds_var ev_binds'
+                    ; setSolvedDicts solved_dicts'
+                    ; return True } }
+
+  | otherwise
+  = return False
   where
     -- This `CtLoc` is used only to check the well-staged condition of any
     -- candidate DFun. Our subgoals all have the same stage as our root
     -- [W] constraint so it is safe to use this while solving them.
     loc_w = ctEvLoc ev_w
 
+    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]
+      :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
+      -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+    try_solve_from_instance (ev_binds, solved_dicts) ev
+      | let pred = ctEvPred ev
+            loc  = ctEvLoc  ev
+      , ClassPred cls tys <- classifyPredType pred
+      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
+           ; case inst_res of
+               OneInst { cir_new_theta = preds
+                       , cir_mk_ev     = mk_ev
+                       , cir_what      = what }
+                 | safeOverlap what
+                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]
+                 -> do { let solved_dicts' = addDict solved_dicts cls tys ev
+                             -- solved_dicts': it is important that we add our goal
+                             -- to the cache before we solve! Otherwise we may end
+                             -- up in a loop while solving recursive dictionaries.
+
+                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
+                       ; loc' <- lift $ checkInstanceOK loc what pred
+
+                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
+                                  -- Emit work for subgoals but use our local cache
+                                  -- so we can solve recursive dictionaries.
+
+                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)
+                             ev_binds' = extendEvBinds ev_binds $
+                                         mkWantedEvBind (ctEvEvId ev) ev_tm
+
+                       ; foldlM try_solve_from_instance
+                                (ev_binds', solved_dicts')
+                                (freshGoals evc_vs) }
+
+               _ -> mzero }
+      | otherwise = mzero
+
+
     -- Use a local cache of solved dicts while emitting EvVars for new work
     -- We bail out of the entire computation if we need to emit an EvVar for
     -- a subgoal that isn't a ClassPred.
-    new_wanted_cached :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
-    new_wanted_cached cache pty
+    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
+    new_wanted_cached loc cache pty
       | ClassPred cls tys <- classifyPredType pty
-      = lift $ case findDict cache cls tys of
-          Just ctev -> return $ Cached (ctEvTerm ctev)
-          Nothing -> Fresh <$> newWantedNC loc_w pty
-      | otherwise = mzero
-
-    -- MaybeT manages early failure if we find a subgoal that cannot be solved
-    -- from instances.
-    -- Why do we need a local cache here?
-    -- 1. We can't use the global cache because it contains givens that
-    --    we specifically don't want to use to solve.
-    -- 2. We need to be able to handle recursive super classes. The
-    --    cache ensures that we remember what we have already tried to
-    --    solve to avoid looping.
-    try_solve_from_instance
-      :: DictMap CtEvidence -> CtEvidence
-      -> MaybeT TcS [(EvTerm, CtEvidence, Class, [TcPredType])]
-    try_solve_from_instance cache ev
-      | ClassPred cls tys <- classifyPredType (ctEvPred ev) = do
-      -- It is important that we add our goal to the cache before we solve!
-      -- Otherwise we may end up in a loop while solving recursive dictionaries.
-      { let cache' = addDict cache cls tys ev
-      ; inst_res <- lift $ match_class_inst dflags cls tys loc_w
-      ; case inst_res of
-          GenInst { lir_new_theta = preds
-                  , lir_mk_ev = mk_ev
-                  , lir_safe_over = safeOverlap }
-            | safeOverlap -> do
-              -- emit work for subgoals but use our local cache so that we can
-              -- solve recursive dictionaries.
-              { evc_vs <- mapM (new_wanted_cached cache') preds
-              ; subgoalBinds <- mapM (try_solve_from_instance cache')
-                                     (freshGoals evc_vs)
-              ; return $ (mk_ev (map getEvTerm evc_vs), ev, cls, preds)
-                       : concat subgoalBinds }
-
-            | otherwise -> mzero
-          _ -> mzero }
+      = lift $ case findDict cache loc_w cls tys of
+          Just ctev -> return $ Cached (ctEvExpr ctev)
+          Nothing   -> Fresh <$> newWantedNC loc pty
       | otherwise = mzero
 
 addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
@@ -987,12 +1170,19 @@ addFunDepWork inerts work_ev cls
 
     add_fds inert_ct
       | isImprovable inert_ev
-      = emitFunDepDeriveds $
+      = do { traceTcS "addFunDepWork" (vcat
+                [ ppr work_ev
+                , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
+                , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;
+
+        emitFunDepDeriveds $
         improveFromAnother derived_loc inert_pred work_pred
                -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
                -- NB: We do create FDs for given to report insoluble equations that arise
                -- from pairs of Givens, and also because of floating when we approximate
                -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
+        }
       | otherwise
       = return ()
       where
@@ -1032,7 +1222,6 @@ interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
 
 interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
 
-
 {- Note [Shadowing of Implicit Parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following example:
@@ -1171,7 +1360,7 @@ improveLocalFunEqs work_ev inerts fam_tc args fsk
     rhs           = lookupFlattenTyVar ieqs fsk
     work_loc      = ctEvLoc work_ev
     work_pred     = ctEvPred work_ev
-    fam_inj_info  = familyTyConInjectivityInfo fam_tc
+    fam_inj_info  = tyConInjectivityInfo fam_tc
 
     --------------------
     improvement_eqns :: [FunDepEqn CtLoc]
@@ -1226,26 +1415,9 @@ reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1
            -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2
            -> TcS ()
 reactFunEq from_this fsk1 solve_this fsk2
-  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- solve_this
-  = do { let fsk_eq_co = mkTcSymCo (mkTcCoVarCo evar) `mkTcTransCo`
-                         ctEvCoercion from_this
-                         -- :: fsk2 ~ fsk1
-             fsk_eq_pred = mkTcEqPredLikeEv solve_this
-                             (mkTyVarTy fsk2) (mkTyVarTy fsk1)
-
-       ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co)
-       ; emitWorkNC [new_ev] }
-
-  | CtDerived { ctev_loc = loc } <- solve_this
-  = do { traceTcS "reactFunEq (Derived)" (ppr from_this $$ ppr fsk1 $$
-                                          ppr solve_this $$ ppr fsk2)
-       ; emitNewDerivedEq loc Nominal (mkTyVarTy fsk1) (mkTyVarTy fsk2) }
-              -- FunEqs are always at Nominal role
-
-  | otherwise  -- Wanted
-  = do { traceTcS "reactFunEq" (ppr from_this $$ ppr fsk1 $$
-                                ppr solve_this $$ ppr fsk2)
-       ; dischargeFmv solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
+  = do { traceTcS "reactFunEq"
+            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
+       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
        ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
                                      ppr solve_this $$ ppr fsk2) }
 
@@ -1298,9 +1470,9 @@ Initial inert set:
 Work item:
   [W] g2 : F a ~ beta2
 The work item will react with the inert yielding the _same_ inert set plus:
-    i)   Will set g2 := g1 `cast` g3
-    ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
-    iii) Will emit [W] g3 : beta1 ~ beta2
+    (i)   Will set g2 := g1 `cast` g3
+    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
+    (iii) Will emit [W] g3 : beta1 ~ beta2
 Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
 and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
 will set
@@ -1376,24 +1548,26 @@ test when solving pairwise CFunEqCan.
 **********************************************************************
 -}
 
-inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtEvidence
+inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole
                    -> Maybe ( CtEvidence  -- The evidence for the inert
                             , SwapFlag    -- Whether we need mkSymCo
                             , Bool)       -- True <=> keep a [D] version
                                           --          of the [WD] constraint
-inertsCanDischarge inerts tv rhs ev
-  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
+inertsCanDischarge inerts tv rhs fr
+  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
                              <- findTyEqs inerts tv
-                         , ev_i `eqCanDischarge` ev
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
                          , rhs_i `tcEqType` rhs ]
   =  -- Inert:     a ~ ty
      -- Work item: a ~ ty
     Just (ev_i, NotSwapped, keep_deriv ev_i)
 
   | Just tv_rhs <- getTyVar_maybe rhs
-  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
+  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
                              <- findTyEqs inerts tv_rhs
-                         , ev_i `eqCanDischarge` ev
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
                          , rhs_i `tcEqType` mkTyVarTy tv ]
   =  -- Inert:     a ~ b
      -- Work item: b ~ a
@@ -1405,7 +1579,7 @@ inertsCanDischarge inerts tv rhs ev
   where
     keep_deriv ev_i
       | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]
-      , Wanted WDeriv <- ctEvFlavour ev    -- work item is [WD]
+      , (Wanted WDeriv, _) <- fr           -- work item is [WD]
       = True   -- Keep a derived verison of the work item
       | otherwise
       = False  -- Work item is fully discharged
@@ -1417,9 +1591,9 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
                                           , cc_ev = ev
                                           , cc_eq_rel = eq_rel })
   | Just (ev_i, swapped, keep_deriv)
-       <- inertsCanDischarge inerts tv rhs ev
+       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
   = do { setEvBindIfWanted ev $
-         EvCoercion (maybeSym swapped $
+         evCoercion (maybeSym swapped $
                      tcDowngradeRole (eqRelRole eq_rel)
                                      (ctEvRole ev_i)
                                      (ctEvCoercion ev_i))
@@ -1433,31 +1607,21 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
 
        ; stopWith ev "Solved from inert" }
 
-  | ReprEq <- eq_rel   -- We never solve representational
-  = unsolved_inert     -- equalities by unification
+  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
+  = do { traceTcS "Not unifying representational equality" (ppr workItem)
+       ; continueWith workItem }
 
   | isGiven ev         -- See Note [Touchables and givens]
-  = unsolved_inert
+  = continueWith workItem
 
   | otherwise
   = do { tclvl <- getTcLevel
        ; if canSolveByUnification tclvl tv rhs
          then do { solveByUnification ev tv rhs
                  ; n_kicked <- kickOutAfterUnification tv
-                 ; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) }
+                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
 
-         else unsolved_inert }
-
-  where
-    unsolved_inert
-      = do { traceTcS "Can't solve tyvar equality"
-                (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-                      , ppWhen (isMetaTyVar tv) $
-                        nest 4 (text "TcLevel of" <+> ppr tv
-                                <+> text "is" <+> ppr (metaTyVarTcLevel tv))
-                      , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) ])
-           ; addInertEq workItem
-           ; stopWith ev "Kept as inert" }
+         else continueWith workItem }
 
 interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
 
@@ -1485,11 +1649,7 @@ solveByUnification wd tv xi
                              text "Right Kind is:" <+> ppr (typeKind xi) ]
 
        ; unifyTyVar tv xi
-       ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi)) }
-
-ppr_kicked :: Int -> SDoc
-ppr_kicked 0 = empty
-ppr_kicked n = parens (int n <+> text "kicked out")
+       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }
 
 {- Note [Avoid double unifications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1509,6 +1669,22 @@ See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
 double unifications is the main reason we disallow touchable
 unification variables as RHS of type family equations: F xis ~ alpha.
 
+Note [Do not unify representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   [W] alpha ~R# b
+where alpha is touchable. Should we unify alpha := b?
+
+Certainly not!  Unifying forces alpha and be to be the same; but they
+only need to be representationally equal types.
+
+For example, we might have another constraint [W] alpha ~# N b
+where
+  newtype N b = MkN b
+and we want to get alpha := N b.
+
+See also Trac #15144, which was caused by unifying a representational
+equality (in the unflattener).
+
 
 ************************************************************************
 *                                                                      *
@@ -1608,10 +1784,10 @@ emitFunDepDeriveds fd_eqns
   where
     do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
      | null tvs  -- Common shortcut
-     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs)
+     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
           ; mapM_ (unifyDerived loc Nominal) eqs }
      | otherwise
-     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr eqs)
+     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
           ; subst <- instFlexi tvs  -- Takes account of kind substitution
           ; mapM_ (do_one_eq loc subst) eqs }
 
@@ -1628,31 +1804,38 @@ emitFunDepDeriveds fd_eqns
 -}
 
 topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
-topReactionsStage wi
- = do { tir <- doTopReact wi
-      ; case tir of
-          ContinueWith wi -> continueWith wi
-          Stop ev s       -> return (Stop ev (text "Top react:" <+> s)) }
-
-doTopReact :: WorkItem -> TcS (StopOrContinue Ct)
--- The work item does not react with the inert set, so try interaction with top-level
--- instances. Note:
---
---   (a) The place to add superclasses in not here in doTopReact stage.
---       Instead superclasses are added in the worklist as part of the
---       canonicalization process. See Note [Adding superclasses].
-
-doTopReact work_item
+-- The work item does not react with the inert set,
+-- so try interaction with top-level instances. Note:
+topReactionsStage work_item
   = do { traceTcS "doTopReact" (ppr work_item)
        ; case work_item of
            CDictCan {}  -> do { inerts <- getTcSInerts
                               ; doTopReactDict inerts work_item }
            CFunEqCan {} -> doTopReactFunEq work_item
+           CIrredCan {} -> doTopReactOther work_item
+           CTyEqCan {}  -> doTopReactOther work_item
            _  -> -- Any other work item does not react with any top-level equations
                  continueWith work_item  }
 
 
 --------------------
+doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
+-- Try local quantified constraints for
+--     CTyEqCan  e.g.  (a ~# ty)
+-- and CIrredCan e.g.  (c a)
+--
+-- Why equalities? See TcCanonical
+-- Note [Equality superclasses in quantified constraints]
+doTopReactOther work_item
+  = do { res <- matchLocalInst pred (ctEvLoc ev)
+       ; case res of
+           OneInst {} -> chooseInstance work_item res
+           _          -> continueWith work_item }
+  where
+    ev = ctEvidence work_item
+    pred = ctEvPred ev
+
+--------------------
 doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
 doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
                                      , cc_tyargs = args, cc_fsk = fsk })
@@ -1678,40 +1861,25 @@ reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)
                   -> TcS (StopOrContinue Ct)
 -- We have found an applicable top-level axiom: use it to reduce
 -- Precondition: fsk is not free in rhs_ty
---               old_ev is not Derived
 reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
-  | isDerived old_ev
-  = do { emitNewDerivedEq loc Nominal (mkTyVarTy fsk) rhs_ty
-       ; stopWith old_ev "Fun/Top (derived)" }
-
-  | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
+  | not (isDerived old_ev)  -- Precondition of shortCutReduction
+  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
   , isTypeFamilyTyCon tc
   , tc_args `lengthIs` tyConArity tc    -- Short-cut
   = -- RHS is another type-family application
     -- Try shortcut; see Note [Top-level reductions for type functions]
-    shortCutReduction old_ev fsk ax_co tc tc_args
-
-  | isGiven old_ev  -- Not shortcut
-  = do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co
-              -- final_co :: fsk ~ rhs_ty
-       ; new_ev <- newGivenEvVar deeper_loc (mkPrimEqPred (mkTyVarTy fsk) rhs_ty,
-                                             EvCoercion final_co)
-       ; emitWorkNC [new_ev] -- Non-cannonical; that will mean we flatten rhs_ty
-       ; stopWith old_ev "Fun/Top (given)" }
+    do { shortCutReduction old_ev fsk ax_co tc tc_args
+       ; stopWith old_ev "Fun/Top (shortcut)" }
 
-  | otherwise   -- So old_ev is Wanted (cannot be Derived)
+  | otherwise
   = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
            , ppr old_ev $$ ppr rhs_ty )
            -- Guaranteed by Note [FunEq occurs-check principle]
-    do { dischargeFmv old_ev fsk ax_co rhs_ty
+    do { dischargeFunEq old_ev fsk ax_co rhs_ty
        ; traceTcS "doTopReactFunEq" $
          vcat [ text "old_ev:" <+> ppr old_ev
               , nest 2 (text ":=") <+> ppr ax_co ]
-       ; stopWith old_ev "Fun/Top (wanted)" }
-
-  where
-    loc = ctEvLoc old_ev
-    deeper_loc = bumpCtLocDepth loc
+       ; stopWith old_ev "Fun/Top" }
 
 improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
 -- See Note [FunDep and implicit parameter reactions]
@@ -1729,7 +1897,8 @@ improveTopFunEqs ev fam_tc args fsk
                                           , ppr eqns ])
        ; mapM_ (unifyDerived loc Nominal) eqns }
   where
-    loc = ctEvLoc ev
+    loc = ctEvLoc ev  -- ToDo: this location is wrong; it should be FunDepOrigin2
+                      -- See Trac #14778
 
 improve_top_fun_eqs :: FamInstEnvs
                     -> TyCon -> [TcType] -> TcType
@@ -1740,7 +1909,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
 
   -- see Note [Type inference for type families with injectivity]
   | isOpenTypeFamilyTyCon fam_tc
-  , Injective injective_args <- familyTyConInjectivityInfo fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
   , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
   = -- it is possible to have several compatible equations in an open type
     -- family but we only want to derive equalities from one such equation.
@@ -1752,7 +1921,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
          take 1 improvs }
 
   | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
-  , Injective injective_args <- familyTyConInjectivityInfo fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
   = concatMapM (injImproveEqns injective_args) $
     buildImprovementData (fromBranches (co_ax_branches ax))
                          cab_tvs cab_lhs cab_rhs Just
@@ -1805,61 +1974,35 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
 
 
 shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
-                  -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
+                  -> TyCon -> [TcType] -> TcS ()
 -- See Note [Top-level reductions for type functions]
+-- Previously, we flattened the tc_args here, but there's no need to do so.
+-- And, if we did, this function would have all the complication of
+-- TcCanonical.canCFunEqCan. See Note [canCFunEqCan]
 shortCutReduction old_ev fsk ax_co fam_tc tc_args
   = ASSERT( ctEvEqRel old_ev == NomEq)
-    do { (xis, cos) <- flattenManyNom old_ev tc_args
                -- ax_co :: F args ~ G tc_args
-               -- cos   :: xis ~ tc_args
                -- old_ev :: F args ~ fsk
-               -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
-
-       ; new_ev <- case ctEvFlavour old_ev of
+    do { new_ev <- case ctEvFlavour old_ev of
            Given -> newGivenEvVar deeper_loc
-                         ( mkPrimEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
-                         , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos
-                                        `mkTcTransCo` mkTcSymCo ax_co
-                                        `mkTcTransCo` ctEvCoercion old_ev) )
+                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                         , evCoercion (mkTcSymCo ax_co
+                                       `mkTcTransCo` ctEvCoercion old_ev) )
 
            Wanted {} ->
              do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
-                                        (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
-                ; setWantedEq (ctev_dest old_ev) $
-                     ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal
-                                                      fam_tc cos)
-                           `mkTcTransCo` new_co
+                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
                 ; return new_ev }
 
            Derived -> pprPanic "shortCutReduction" (ppr old_ev)
 
        ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
-                                , cc_tyargs = xis, cc_fsk = fsk }
-       ; updWorkListTcS (extendWorkListFunEq new_ct)
-       ; stopWith old_ev "Fun/Top (shortcut)" }
+                                , cc_tyargs = tc_args, cc_fsk = fsk }
+       ; updWorkListTcS (extendWorkListFunEq new_ct) }
   where
     deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
 
-dischargeFmv :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
--- (dischargeFmv x fmv co ty)
---     [W] ev :: F tys ~ fmv
---         co :: F tys ~ xi
--- Precondition: fmv is not filled, and fmv `notElem` xi
---               ev is Wanted
---
--- Then set fmv := xi,
---      set ev  := co
---      kick out any inert things that are now rewritable
---
--- Does not evaluate 'co' if 'ev' is Derived
-dischargeFmv ev@(CtWanted { ctev_dest = dest }) fmv co xi
-  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
-    do { setWantedEvTerm dest (EvCoercion co)
-       ; unflattenFmv fmv xi
-       ; n_kicked <- kickOutAfterUnification fmv
-       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }
-dischargeFmv ev _ _ _ = pprPanic "dischargeFmv" (ppr ev)
-
 {- Note [Top-level reductions for type functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 c.f. Note [The flattening story] in TcFlatten
@@ -1982,9 +2125,9 @@ favour of alpha.  If we instead had
 then we would unify alpha := gamma1; and kick out the wanted
 constraint.  But when we grough it back in, it'd look like
    [W] TF (gamma1, beta) ~ fuv
-and exactly the same thing would happen again!  Infnite loop.
+and exactly the same thing would happen again!  Infinite loop.
 
-This all sesms fragile, and it might seem more robust to avoid
+This all seems fragile, and it might seem more robust to avoid
 introducing gamma1 in the first place, in the case where the
 actual argument (alpha, beta) partly matches the improvement
 template.  But that's a bit tricky, esp when we remember that the
@@ -2064,62 +2207,33 @@ Another example is indexed-types/should_compile/T10634
 
 doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
 -- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
+doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
                                           , cc_tyargs = xis })
-  | isGiven fl   -- Never use instances for Given constraints
+  | isGiven ev   -- Never use instances for Given constraints
   = do { try_fundep_improvement
        ; continueWith work_item }
 
-  | Just ev <- lookupSolvedDict inerts cls xis   -- Cached
-  = do { setEvBindIfWanted fl (ctEvTerm ev)
-       ; stopWith fl "Dict/Top (cached)" }
+  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
+  = do { setEvBindIfWanted ev (ctEvTerm solved_ev)
+       ; stopWith ev "Dict/Top (cached)" }
 
   | otherwise  -- Wanted or Derived, but not cached
    = do { dflags <- getDynFlags
-        ; lkup_inst_res <- matchClassInst dflags inerts cls xis dict_loc
-        ; case lkup_inst_res of
-               GenInst { lir_new_theta = theta
-                       , lir_mk_ev     = mk_ev
-                       , lir_safe_over = s } ->
-                 do { traceTcS "doTopReact/found instance for" $ ppr fl
-                    ; checkReductionDepth deeper_loc dict_pred
-                    ; unless s $ insertSafeOverlapFailureTcS work_item
-                    ; if isDerived fl then finish_derived theta
-                                      else finish_wanted  theta mk_ev }
-               NoInstance ->
-                 do { when (isImprovable fl) $
-                      try_fundep_improvement
-                    ; continueWith work_item } }
+        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+        ; case lkup_res of
+               OneInst { cir_what = what }
+                  -> do { unless (safeOverlap what) $
+                          insertSafeOverlapFailureTcS work_item
+                        ; when (isWanted ev) $ addSolvedDict ev cls xis
+                        ; chooseInstance work_item lkup_res }
+               _  ->  -- NoInstance or NotSure
+                     do { when (isImprovable ev) $
+                          try_fundep_improvement
+                        ; continueWith work_item } }
    where
      dict_pred   = mkClassPred cls xis
-     dict_loc    = ctEvLoc fl
+     dict_loc    = ctEvLoc ev
      dict_origin = ctLocOrigin dict_loc
-     deeper_loc  = zap_origin (bumpCtLocDepth dict_loc)
-
-     zap_origin loc  -- After applying an instance we can set ScOrigin to
-                     -- infinity, so that prohibitedSuperClassSolve never fires
-       | ScOrigin {} <- dict_origin
-       = setCtLocOrigin loc (ScOrigin infinity)
-       | otherwise
-       = loc
-
-     finish_wanted :: [TcPredType]
-                   -> ([EvTerm] -> EvTerm) -> TcS (StopOrContinue Ct)
-      -- Precondition: evidence term matches the predicate workItem
-     finish_wanted theta mk_ev
-        = do { addSolvedDict fl cls xis
-             ; evc_vars <- mapM (newWanted deeper_loc) theta
-             ; setWantedEvBind (ctEvId fl) (mk_ev (map getEvTerm evc_vars))
-             ; emitWorkNC (freshGoals evc_vars)
-             ; stopWith fl "Dict/Top (solved wanted)" }
-
-     finish_derived theta  -- Use type-class instances for Deriveds, in the hope
-       =                   -- of generating some improvements
-                           -- C.f. Example 3 of Note [The improvement story]
-                           -- It's easy because no evidence is involved
-         do { emitNewDeriveds deeper_loc theta
-            ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))
-            ; stopWith fl "Dict/Top (solved derived)" }
 
      -- We didn't solve it; so try functional dependencies with
      -- the instance environment, and return
@@ -2140,38 +2254,95 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
 doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
 
 
-{- *******************************************************************
-*                                                                    *
-                       Class lookup
-*                                                                    *
-**********************************************************************-}
+chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
+chooseInstance work_item
+               (OneInst { cir_new_theta = theta
+                        , cir_what      = what
+                        , cir_mk_ev     = mk_ev })
+  = do { traceTcS "doTopReact/found instance for" $ ppr ev
+       ; deeper_loc <- checkInstanceOK loc what pred
+       ; if isDerived ev then finish_derived deeper_loc theta
+                         else finish_wanted  deeper_loc theta mk_ev }
+  where
+     ev         = ctEvidence work_item
+     pred       = ctEvPred ev
+     loc        = ctEvLoc ev
 
--- | Indicates if Instance met the Safe Haskell overlapping instances safety
--- check.
---
--- See Note [Safe Haskell Overlapping Instances] in TcSimplify
--- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
-type SafeOverlapping = Bool
+     finish_wanted :: CtLoc -> [TcPredType]
+                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)
+      -- Precondition: evidence term matches the predicate workItem
+     finish_wanted loc theta mk_ev
+        = do { evb <- getTcEvBindsVar
+             ; if isCoEvBindsVar evb
+               then -- See Note [Instances in no-evidence implications]
+                    continueWith work_item
+               else
+          do { evc_vars <- mapM (newWanted loc) theta
+             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
+             ; emitWorkNC (freshGoals evc_vars)
+             ; stopWith ev "Dict/Top (solved wanted)" } }
+
+     finish_derived loc theta
+       = -- Use type-class instances for Deriveds, in the hope
+         -- of generating some improvements
+         -- C.f. Example 3 of Note [The improvement story]
+         -- It's easy because no evidence is involved
+         do { emitNewDeriveds loc theta
+            ; traceTcS "finish_derived" (ppr (ctl_depth loc))
+            ; stopWith ev "Dict/Top (solved derived)" }
+
+chooseInstance work_item lookup_res
+  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
+
+checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
+-- Check that it's OK to use this insstance:
+--    (a) the use is well staged in the Template Haskell sense
+--    (b) we have not recursed too deep
+-- Returns the CtLoc to used for sub-goals
+checkInstanceOK loc what pred
+  = do { checkWellStagedDFun loc what pred
+       ; checkReductionDepth deeper_loc pred
+       ; return deeper_loc }
+  where
+     deeper_loc = zap_origin (bumpCtLocDepth loc)
+     origin     = ctLocOrigin loc
 
-data LookupInstResult
-  = NoInstance
-  | GenInst { lir_new_theta :: [TcPredType]
-            , lir_mk_ev     :: [EvTerm] -> EvTerm
-            , lir_safe_over :: SafeOverlapping }
+     zap_origin loc  -- After applying an instance we can set ScOrigin to
+                     -- infinity, so that prohibitedSuperClassSolve never fires
+       | ScOrigin {} <- origin
+       = setCtLocOrigin loc (ScOrigin infinity)
+       | otherwise
+       = loc
 
-instance Outputable LookupInstResult where
-  ppr NoInstance = text "NoInstance"
-  ppr (GenInst { lir_new_theta = ev
-               , lir_safe_over = s })
-    = text "GenInst" <+> vcat [ppr ev, ss]
-    where ss = text $ if s then "[safe]" else "[unsafe]"
+{- Note [Instances in no-evidence implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Trac #15290 we had
+  [G] forall p q. Coercible p q => Coercible (m p) (m q))
+  [W] forall <no-ev> a. m (Int, IntStateT m a)
+                          ~R#
+                        m (Int, StateT Int m a)
+
+The Given is an ordinary quantified constraint; the Wanted is an implication
+equality that arises from
+  [W] (forall a. t1) ~R# (forall a. t2)
+
+But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
+we can't generate any term evidence.  So we can't actually use that
+lovely quantified constraint.  Alas!
+
+This test arranges to ignore the instance-based solution under these
+(rare) circumstances.   It's sad, but I  really don't see what else we can do.
+-}
 
 
-matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchClassInst :: DynFlags -> InertSet
+               -> Class -> [Type]
+               -> CtLoc -> TcS ClsInstResult
 matchClassInst dflags inerts clas tys loc
 -- First check whether there is an in-scope Given that could
--- match this constraint.  In that case, do not use top-level
--- instances.  See Note [Instance and Given overlap]
+-- match this constraint.  In that case, do not use any instance
+-- whether top level, or local quantified constraints.
+-- ee Note [Instance and Given overlap]
   | not (xopt LangExt.IncoherentInstances dflags)
   , not (naturallyCoherentClass clas)
   , let matchable_givens = matchableGivens loc pred inerts
@@ -2179,28 +2350,39 @@ matchClassInst dflags inerts clas tys loc
   = do { traceTcS "Delaying instance application" $
            vcat [ text "Work item=" <+> pprClassPred clas tys
                 , text "Potential matching givens:" <+> ppr matchable_givens ]
-       ; return NoInstance }
-  where
-     pred = mkClassPred clas tys
-
-matchClassInst dflags _ clas tys loc
- = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr (mkClassPred clas tys) <+> char '{'
-      ; res <- match_class_inst dflags clas tys loc
-      ; traceTcS "} matchClassInst result" $ ppr res
-      ; return res }
-
-match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-match_class_inst dflags clas tys loc
-  | cls_name == knownNatClassName     = matchKnownNat        clas tys
-  | cls_name == knownSymbolClassName  = matchKnownSymbol     clas tys
-  | isCTupleClass clas                = matchCTuple          clas tys
-  | cls_name == typeableClassName     = matchTypeable        clas tys
-  | clas `hasKey` heqTyConKey         = matchLiftedEquality       tys
-  | clas `hasKey` coercibleTyConKey   = matchLiftedCoercible      tys
-  | cls_name == hasFieldClassName     = matchHasField dflags clas tys loc
-  | otherwise                         = matchInstEnv dflags clas tys loc
+       ; return NotSure }
+
+  | otherwise
+  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
+       ; local_res <- matchLocalInst pred loc
+       ; case local_res of
+           OneInst {} ->  -- See Note [Local instances and incoherence]
+                do { traceTcS "} matchClassInst local match" $ ppr local_res
+                   ; return local_res }
+
+           NotSure -> -- In the NotSure case for local instances
+                      -- we don't want to try global instances
+                do { traceTcS "} matchClassInst local not sure" empty
+                   ; return local_res }
+
+           NoInstance  -- No local instances, so try global ones
+              -> do { global_res <- matchGlobalInst dflags False clas tys
+                    ; traceTcS "} matchClassInst global result" $ ppr global_res
+                    ; return global_res } }
   where
-    cls_name = className clas
+    pred = mkClassPred clas tys
+
+-- | If a class is "naturally coherent", then we needn't worry at all, in any
+-- way, about overlapping/incoherent instances. Just solve the thing!
+-- See Note [Naturally coherent classes]
+-- See also Note [The equality class story] in TysPrim.
+naturallyCoherentClass :: Class -> Bool
+naturallyCoherentClass cls
+  = isCTupleClass cls
+    || cls `hasKey` heqTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` coercibleTyConKey
+
 
 {- Note [Instance and Given overlap]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2285,394 +2467,117 @@ Other notes:
 All of this is disgustingly delicate, so to discourage people from writing
 simplifiable class givens, we warn about signatures that contain them;
 see TcValidity Note [Simplifiable given constraints].
--}
-
-
-{- *******************************************************************
-*                                                                    *
-                Class lookup in the instance environment
-*                                                                    *
-**********************************************************************-}
-
-matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-matchInstEnv dflags clas tys loc
-   = do { instEnvs <- getInstEnvs
-        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
-              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
-              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
-        ; case (matches, unify, safeHaskFail) of
-
-            -- Nothing matches
-            ([], _, _)
-                -> do { traceTcS "matchClass not matching" $
-                        vcat [ text "dict" <+> ppr pred ]
-                      ; return NoInstance }
-
-            -- A single match (& no safe haskell failure)
-            ([(ispec, inst_tys)], [], False)
-                -> do   { let dfun_id = instanceDFunId ispec
-                        ; traceTcS "matchClass success" $
-                          vcat [text "dict" <+> ppr pred,
-                                text "witness" <+> ppr dfun_id
-                                               <+> ppr (idType dfun_id) ]
-                                  -- Record that this dfun is needed
-                        ; match_one (null unsafeOverlaps) dfun_id inst_tys }
-
-            -- More than one matches (or Safe Haskell fail!). Defer any
-            -- reactions of a multitude until we learn more about the reagent
-            (matches, _, _)
-                -> do   { traceTcS "matchClass multiple matches, deferring choice" $
-                          vcat [text "dict" <+> ppr pred,
-                                text "matches" <+> ppr matches]
-                        ; return NoInstance } }
-   where
-     pred = mkClassPred clas tys
-
-     match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult
-                  -- See Note [DFunInstType: instantiating types] in InstEnv
-     match_one so dfun_id mb_inst_tys
-       = do { checkWellStagedDFun pred dfun_id loc
-            ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
-            ; return $ GenInst { lir_new_theta = theta
-                               , lir_mk_ev     = EvDFunApp dfun_id tys
-                               , lir_safe_over = so } }
-
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for CTuples
-*                                                                     *
-***********************************************************************-}
-
-matchCTuple :: Class -> [Type] -> TcS LookupInstResult
-matchCTuple clas tys   -- (isCTupleClass clas) holds
-  = return (GenInst { lir_new_theta = tys
-                    , lir_mk_ev     = tuple_ev
-                    , lir_safe_over = True })
-            -- The dfun *is* the data constructor!
-  where
-     data_con = tyConSingleDataCon (classTyCon clas)
-     tuple_ev = EvDFunApp (dataConWrapId data_con) tys
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for Literals
-*                                                                     *
-***********************************************************************-}
-
-matchKnownNat :: Class -> [Type] -> TcS LookupInstResult
-matchKnownNat clas [ty]     -- clas = KnownNat
-  | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n)
-matchKnownNat _ _           = return NoInstance
-
-matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult
-matchKnownSymbol clas [ty]  -- clas = KnownSymbol
-  | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n)
-matchKnownSymbol _ _       = return NoInstance
-
-
-makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult
--- makeLitDict adds a coercion that will convert the literal into a dictionary
--- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
--- in TcEvidence.  The coercion happens in 2 steps:
---
---     Integer -> SNat n     -- representation of literal to singleton
---     SNat n  -> KnownNat n -- singleton to dictionary
---
---     The process is mirrored for Symbols:
---     String    -> SSymbol n
---     SSymbol n -> KnownSymbol n -}
-makeLitDict clas ty evLit
-    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
-          -- co_dict :: KnownNat n ~ SNat n
-    , [ meth ]   <- classMethods clas
-    , Just tcRep <- tyConAppTyCon_maybe -- SNat
-                      $ funResultTy         -- SNat n
-                      $ dropForAlls         -- KnownNat n => SNat n
-                      $ idType meth         -- forall n. KnownNat n => SNat n
-    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-          -- SNat n ~ Integer
-    , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep))
-    = return $ GenInst { lir_new_theta = []
-                       , lir_mk_ev     = \_ -> ev_tm
-                       , lir_safe_over = True }
-
-    | otherwise
-    = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
-                     $$ vcat (map (ppr . idType) (classMethods clas)))
-
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for Typeable
-*                                                                     *
-***********************************************************************-}
-
--- | Assumes that we've checked that this is the 'Typeable' class,
--- and it was applied to the correct argument.
-matchTypeable :: Class -> [Type] -> TcS LookupInstResult
-matchTypeable clas [k,t]  -- clas = Typeable
-  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
-  | isForAllTy k                      = return NoInstance   -- Polytype
-  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type
-
-  -- Now cases that do work
-  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t
-  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t
-  | isConstraintKind t                     = doTyConApp clas t constraintKindTyCon []
-  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret
-  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
-  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
-  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
-
-matchTypeable _ _ = return NoInstance
-
--- | Representation for a type @ty@ of the form @arg -> ret@.
-doFunTy :: Class -> Type -> Type -> Type -> TcS LookupInstResult
-doFunTy clas ty arg_ty ret_ty
-  = do { let preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]
-             build_ev [arg_ev, ret_ev] =
-                 EvTypeable ty $ EvTypeableTrFun arg_ev ret_ev
-             build_ev _ = panic "TcInteract.doFunTy"
-       ; return $ GenInst preds build_ev True
-       }
-
--- | Representation for type constructor applied to some kinds.
--- 'onlyNamedBndrsApplied' has ensured that this application results in a type
--- of monomorphic kind (e.g. all kind variables have been instantiated).
-doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcS LookupInstResult
-doTyConApp clas ty tc kind_args
-  = return $ GenInst (map (mk_typeable_pred clas) kind_args)
-                     (\kinds -> EvTypeable ty $ EvTypeableTyCon tc kinds)
-                     True
-
--- | Representation for TyCon applications of a concrete kind. We just use the
--- kind itself, but first we must make sure that we've instantiated all kind-
--- polymorphism, but no more.
-onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
-onlyNamedBndrsApplied tc ks
- = all isNamedTyConBinder used_bndrs &&
-   not (any isNamedTyConBinder leftover_bndrs)
- where
-   bndrs                        = tyConBinders tc
-   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs
-
-doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult
--- Representation for an application of a type to a type-or-kind.
---  This may happen when the type expression starts with a type variable.
---  Example (ignoring kind parameter):
---    Typeable (f Int Char)                      -->
---    (Typeable (f Int), Typeable Char)          -->
---    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
---    Typeable f
-doTyApp clas ty f tk
-  | isForAllTy (typeKind f)
-  = return NoInstance -- We can't solve until we know the ctr.
-  | otherwise
-  = return $ GenInst (map (mk_typeable_pred clas) [f, tk])
-                     (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2)
-                     True
-
--- Emit a `Typeable` constraint for the given type.
-mk_typeable_pred :: Class -> Type -> PredType
-mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
-
-  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
-  -- we generate a sub-goal for the appropriate class. See #10348 for what
-  -- happens when we fail to do this.
-doTyLit :: Name -> Type -> TcS LookupInstResult
-doTyLit kc t = do { kc_clas <- tcLookupClass kc
-                  ; let kc_pred    = mkClassPred kc_clas [ t ]
-                        mk_ev [ev] = EvTypeable t $ EvTypeableTyLit ev
-                        mk_ev _    = panic "doTyLit"
-                  ; return (GenInst [kc_pred] mk_ev True) }
-
-{- Note [Typeable (T a b c)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For type applications we always decompose using binary application,
-via doTyApp, until we get to a *kind* instantiation.  Example
-   Proxy :: forall k. k -> *
-
-To solve Typeable (Proxy (* -> *) Maybe) we
-  - First decompose with doTyApp,
-    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
-  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp
-
-If we attempt to short-cut by solving it all at once, via
-doTyConApp
-
-(this note is sadly truncated FIXME)
-
 
-Note [No Typeable for polytypes or qualified types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not support impredicative typeable, such as
-   Typeable (forall a. a->a)
-   Typeable (Eq a => a -> a)
-   Typeable (() => Int)
-   Typeable (((),()) => Int)
-
-See Trac #9858.  For forall's the case is clear: we simply don't have
-a TypeRep for them.  For qualified but not polymorphic types, like
-(Eq a => a -> a), things are murkier.  But:
-
- * We don't need a TypeRep for these things.  TypeReps are for
-   monotypes only.
-
- * Perhaps we could treat `=>` as another type constructor for `Typeable`
-   purposes, and thus support things like `Eq Int => Int`, however,
-   at the current state of affairs this would be an odd exception as
-   no other class works with impredicative types.
-   For now we leave it off, until we have a better story for impredicativity.
+Note [Naturally coherent classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A few built-in classes are "naturally coherent".  This term means that
+the "instance" for the class is bidirectional with its superclass(es).
+For example, consider (~~), which behaves as if it was defined like
+this:
+  class a ~# b => a ~~ b
+  instance a ~# b => a ~~ b
+(See Note [The equality types story] in TysPrim.)
+
+Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
+without worrying about Note [Instance and Given overlap].  Why?  Because
+if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
+so the reduction of the [W] constraint does not risk losing any solutions.
+
+On the other hand, it can be fatal to /fail/ to reduce such
+equalities, on the grounds of Note [Instance and Given overlap],
+because many good things flow from [W] t1 ~# t2.
+
+The same reasoning applies to
+
+* (~~)        heqTyCOn
+* (~)         eqTyCon
+* Coercible   coercibleTyCon
+
+And less obviously to:
+
+* Tuple classes.  For reasons described in TcSMonad
+  Note [Tuples hiding implicit parameters], we may have a constraint
+     [W] (?x::Int, C a)
+  with an exactly-matching Given constraint.  We must decompose this
+  tuple and solve the components separately, otherwise we won't solve
+  it at all!  It is perfectly safe to decompose it, because again the
+  superclasses invert the instance;  e.g.
+      class (c1, c2) => (% c1, c2 %)
+      instance (c1, c2) => (% c1, c2 %)
+  Example in Trac #14218
+
+Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b
+
+PS: the term "naturally coherent" doesn't really seem helpful.
+Perhaps "invertible" or something?  I left it for now though.
+
+Note [Local instances and incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
+                 => c b -> Bool
+   f x = x==x
+
+We get [W] Eq (c b), and we must use the local instance to solve it.
+
+BUT that wanted also unifies with the top-level Eq [a] instance,
+and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
+we can't solve the wanted at all.  So we mark it as Incohherent.
+According to Note [Rules for instance lookup] in InstEnv, that'll
+make it win even if there are other instances that unify.
+
+Moreover this is not a hack!  The evidence for this local instance
+will be constructed by GHC at a call site... from the very instances
+that unify with it here.  It is not like an incoherent user-written
+instance which might have utterly different behaviour.
+
+Consdider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
+get it from the Eq a context, without worrying that there are
+lots of top-level instances that unify with [W] Eq a!  We'll use
+those instances to build evidence to pass to f. That's just the
+nullary case of what's happening here.
 -}
 
-solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
-solveCallStack ev ev_cs = do
-  -- We're given ev_cs :: CallStack, but the evidence term should be a
-  -- dictionary, so we have to coerce ev_cs to a dictionary for
-  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
-  let ev_tm = mkEvCast (EvCallStack ev_cs) (wrapIP (ctEvPred ev))
-  setWantedEvBind (ctEvId ev) ev_tm
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for lifted equality
-*                                                                     *
-***********************************************************************-}
-
--- See also Note [The equality types story] in TysPrim
-matchLiftedEquality :: [Type] -> TcS LookupInstResult
-matchLiftedEquality args
-  = return (GenInst { lir_new_theta = [ mkTyConApp eqPrimTyCon args ]
-                    , lir_mk_ev     = EvDFunApp (dataConWrapId heqDataCon) args
-                    , lir_safe_over = True })
-
--- See also Note [The equality types story] in TysPrim
-matchLiftedCoercible :: [Type] -> TcS LookupInstResult
-matchLiftedCoercible args@[k, t1, t2]
-  = return (GenInst { lir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
-                    , lir_mk_ev     = EvDFunApp (dataConWrapId coercibleDataCon)
-                                                args
-                    , lir_safe_over = True })
+matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
+-- Try any Given quantified constraints, which are
+-- effectively just local instance declarations.
+matchLocalInst pred loc
+  = do { ics <- getInertCans
+       ; case match_local_inst (inert_insts ics) of
+           ([], False) -> return NoInstance
+           ([(dfun_ev, inst_tys)], unifs)
+             | not unifs
+             -> do { let dfun_id = ctEvEvId dfun_ev
+                   ; (tys, theta) <- instDFunType dfun_id inst_tys
+                   ; return $ OneInst { cir_new_theta = theta
+                                      , cir_mk_ev     = evDFunApp dfun_id tys
+                                      , cir_what      = LocalInstance } }
+           _ -> return NotSure }
   where
-    args' = [k, k, t1, t2]
-matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
-
-
-{- ********************************************************************
-*                                                                     *
-              Class lookup for overloaded record fields
-*                                                                     *
-***********************************************************************-}
-
-{-
-Note [HasField instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-    data T y = MkT { foo :: [y] }
+    pred_tv_set = tyCoVarsOfType pred
+
+    match_local_inst :: [QCInst]
+                     -> ( [(CtEvidence, [DFunInstType])]
+                        , Bool )      -- True <=> Some unify but do not match
+    match_local_inst []
+      = ([], False)
+    match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred
+                               , qci_ev = ev })
+                     : qcis)
+      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
+      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
+                                        emptyTvSubstEnv qpred pred
+      , let match = (ev, map (lookupVarEnv tv_subst) qtvs)
+      = (match:matches, unif)
 
-and `foo` is in scope.  Then GHC will automatically solve a constraint like
-
-    HasField "foo" (T Int) b
-
-by emitting a new wanted
-
-    T alpha -> [alpha] ~# T Int -> b
-
-and building a HasField dictionary out of the selector function `foo`,
-appropriately cast.
-
-The HasField class is defined (in GHC.Records) thus:
-
-    class HasField (x :: k) r a | x r -> a where
-      getField :: r -> a
-
-Since this is a one-method class, it is represented as a newtype.
-Hence we can solve `HasField "foo" (T Int) b` by taking an expression
-of type `T Int -> b` and casting it using the newtype coercion.
-Note that
-
-    foo :: forall y . T y -> [y]
-
-so the expression we construct is
-
-    foo @alpha |> co
-
-where
-
-    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
-
-is built from
-
-    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
-
-which is the new wanted, and
-
-    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
-
-which can be derived from the newtype coercion.
-
-If `foo` is not in scope, or has a higher-rank or existentially
-quantified type, then the constraint is not solved automatically, but
-may be solved by a user-supplied HasField instance.  Similarly, if we
-encounter a HasField constraint where the field is not a literal
-string, or does not belong to the type, then we fall back on the
-normal constraint solver behaviour.
--}
+      | otherwise
+      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)
+               , ppr qci $$ ppr pred )
+            -- ASSERT: unification relies on the
+            -- quantified variables being fresh
+        (matches, unif || this_unif)
+      where
+        qtv_set = mkVarSet qtvs
+        this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc
+        (matches, unif) = match_local_inst qcis
 
--- See Note [HasField instances]
-matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
-matchHasField dflags clas tys loc
-  = do { fam_inst_envs <- getFamInstEnvs
-       ; rdr_env       <- getGlobalRdrEnvTcS
-       ; case tys of
-           -- We are matching HasField {k} x r a...
-           [_k_ty, x_ty, r_ty, a_ty]
-               -- x should be a literal string
-             | Just x <- isStrLitTy x_ty
-               -- r should be an applied type constructor
-             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
-               -- use representation tycon (if data family); it has the fields
-             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
-               -- x should be a field of r
-             , Just fl <- lookupTyConFieldLabel x r_tc
-               -- the field selector should be in scope
-             , Just gre <- lookupGRE_FieldLabel rdr_env fl
-
-             -> do { sel_id <- tcLookupId (flSelector fl)
-                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
-
-                         -- The first new wanted constraint equates the actual
-                         -- type of the selector with the type (r -> a) within
-                         -- the HasField x r a dictionary.  The preds will
-                         -- typically be empty, but if the datatype has a
-                         -- "stupid theta" then we have to include it here.
-                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
-
-                         -- Use the equality proof to cast the selector Id to
-                         -- type (r -> a), then use the newtype coercion to cast
-                         -- it to a HasField dictionary.
-                         mk_ev (ev1:evs) = EvSelector sel_id tvs evs `EvCast` co
-                           where
-                             co = mkTcSubCo (evTermCoercion ev1)
-                                      `mkTcTransCo` mkTcSymCo co2
-                         mk_ev [] = panic "matchHasField.mk_ev"
-
-                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
-                                                              tys
-
-                         tvs = mkTyVarTys (map snd tv_prs)
-
-                     -- The selector must not be "naughty" (i.e. the field
-                     -- cannot have an existentially quantified type), and
-                     -- it must not be higher-rank.
-                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
-                     then do { addUsedGRE True gre
-                             ; return GenInst { lir_new_theta = theta
-                                              , lir_mk_ev     = mk_ev
-                                              , lir_safe_over = True
-                                              } }
-                     else matchInstEnv dflags clas tys loc }
-
-           _ -> matchInstEnv dflags clas tys loc }
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 0a1de443b3..26d1a33486 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -37,15 +37,11 @@ module TcMType (
   tauifyExpType, inferResultToType,
 
   --------------------------------
-  -- Creating fresh type variables for pm checking
-  genInstSkolTyVarsX,
-
-  --------------------------------
   -- Creating new evidence variables
   newEvVar, newEvVars, newDict,
   newWanted, newWanteds, cloneWanted, cloneWC,
   emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
-  newTcEvBinds, addTcEvBind,
+  newTcEvBinds, newNoTcEvBinds, addTcEvBind,
 
   newCoercionHole, fillCoercionHole, isFilledCoercionHole,
   unpackCoercionHole, unpackCoercionHole_maybe,
@@ -54,22 +50,21 @@ module TcMType (
   --------------------------------
   -- Instantiation
   newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
-  newMetaSigTyVars, newMetaSigTyVarX,
-  newSigTyVar, newWildCardX,
+  newMetaTyVarTyVars, newMetaTyVarTyVarX,
+  newTyVarTyVar, newTauTyVar, newSkolemTyVar, newWildCardX,
   tcInstType,
   tcInstSkolTyVars,tcInstSkolTyVarsX,
   tcInstSuperSkolTyVarsX,
   tcSkolDFunType, tcSuperSkolTyVars,
 
-  instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX,
+  instSkolTyCoVarsX, freshenTyVarBndrs, freshenCoVarBndrsX,
 
   --------------------------------
   -- Zonking and tidying
-  zonkTidyTcType, zonkTidyOrigin,
-  mkTypeErrorThing, mkTypeErrorThingArgs,
+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
   tidyEvVar, tidyCt, tidySkolemInfo,
-  skolemiseRuntimeUnk,
-  zonkTcTyVar, zonkTcTyVars, zonkTcTyVarToTyVar,
+    zonkTcTyVar, zonkTcTyVars,
+  zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
   zonkTyCoVarsAndFV, zonkTcTypeAndFV,
   zonkTyCoVarsAndFVList,
   zonkTcTypeAndSplitDepVars, zonkTcTypesAndSplitDepVars,
@@ -77,9 +72,11 @@ module TcMType (
   quantifyTyVars,
   zonkTcTyCoVarBndr, zonkTcTyVarBinder,
   zonkTcType, zonkTcTypes, zonkCo,
-  zonkTyCoVarKind, zonkTcTypeMapper,
+  zonkTyCoVarKind,
 
-  zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo,
+  zonkEvVar, zonkWC, zonkSimples,
+  zonkId, zonkCoVar,
+  zonkCt, zonkSkolemInfo,
 
   tcGetGlobalTyCoVars,
 
@@ -91,10 +88,11 @@ module TcMType (
 #include "HsVersions.h"
 
 -- friends:
+import GhcPrelude
+
 import TyCoRep
 import TcType
 import Type
-import Kind
 import Coercion
 import Class
 import Var
@@ -143,6 +141,7 @@ newMetaKindVar :: TcM TcKind
 newMetaKindVar = do { uniq <- newUnique
                     ; details <- newMetaDetails TauTv
                     ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details
+                    ; traceTc "newMetaKindVar" (ppr kv)
                     ; return (mkTyVarTy kv) }
 
 newMetaKindVars :: Int -> TcM [TcKind]
@@ -170,7 +169,7 @@ newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
 -- Deals with both equality and non-equality predicates
 newWanted orig t_or_k pty
   = do loc <- getCtLocM orig t_or_k
-       d <- if isEqPred pty then HoleDest  <$> newCoercionHole
+       d <- if isEqPred pty then HoleDest  <$> newCoercionHole pty
                             else EvVarDest <$> newEvVar pty
        return $ CtWanted { ctev_dest = d
                          , ctev_pred = pty
@@ -180,23 +179,38 @@ newWanted orig t_or_k pty
 newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
 newWanteds orig = mapM (newWanted orig Nothing)
 
-cloneWanted :: Ct -> TcM CtEvidence
+----------------------------------------------
+-- Cloning constraints
+----------------------------------------------
+
+cloneWanted :: Ct -> TcM Ct
 cloneWanted ct
-  = newWanted (ctEvOrigin ev) Nothing (ctEvPred ev)
-  where
-    ev = ctEvidence ct
+  | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct
+  = do { co_hole <- newCoercionHole pty
+       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }
+  | otherwise
+  = return ct
 
 cloneWC :: WantedConstraints -> TcM WantedConstraints
+-- Clone all the evidence bindings in
+--   a) the ic_bind field of any implications
+--   b) the CoercionHoles of any wanted constraints
+-- so that solving the WantedConstraints will not have any visible side
+-- effect, /except/ from causing unifications
 cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
-  = do { simples' <- mapBagM clone_one simples
-       ; implics' <- mapBagM clone_implic implics
+  = do { simples' <- mapBagM cloneWanted simples
+       ; implics' <- mapBagM cloneImplication implics
        ; return (wc { wc_simple = simples', wc_impl = implics' }) }
-  where
-    clone_one ct = do { ev <- cloneWanted ct; return (mkNonCanonical ev) }
 
-    clone_implic implic@(Implic { ic_wanted = inner_wanted })
-      = do { inner_wanted' <- cloneWC inner_wanted
-           ; return (implic { ic_wanted = inner_wanted' }) }
+cloneImplication :: Implication -> TcM Implication
+cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })
+  = do { binds'        <- cloneEvBindsVar binds
+       ; inner_wanted' <- cloneWC inner_wanted
+       ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }
+
+----------------------------------------------
+-- Emitting constraints
+----------------------------------------------
 
 -- | Emits a new Wanted. Deals with both equalities and non-equalities.
 emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
@@ -208,12 +222,12 @@ emitWanted origin pty
 -- | Emits a new equality constraint
 emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
 emitWantedEq origin t_or_k role ty1 ty2
-  = do { hole <- newCoercionHole
+  = do { hole <- newCoercionHole pty
        ; loc <- getCtLocM origin (Just t_or_k)
        ; emitSimple $ mkNonCanonical $
          CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
                   , ctev_nosh = WDeriv, ctev_loc = loc }
-       ; return (mkHoleCo hole role ty1 ty2) }
+       ; return (HoleCo hole) }
   where
     pty = mkPrimEqPredRole role ty1 ty2
 
@@ -241,8 +255,9 @@ newDict cls tys
 predTypeOccName :: PredType -> OccName
 predTypeOccName ty = case classifyPredType ty of
     ClassPred cls _ -> mkDictOcc (getOccName cls)
-    EqPred _ _ _    -> mkVarOccFS (fsLit "cobox")
-    IrredPred _     -> mkVarOccFS (fsLit "irred")
+    EqPred {}       -> mkVarOccFS (fsLit "co")
+    IrredPred {}    -> mkVarOccFS (fsLit "irred")
+    ForAllPred {}   -> mkVarOccFS (fsLit "df")
 
 {-
 ************************************************************************
@@ -252,28 +267,28 @@ predTypeOccName ty = case classifyPredType ty of
 ************************************************************************
 -}
 
-newCoercionHole :: TcM CoercionHole
-newCoercionHole
-  = do { u <- newUnique
-       ; traceTc "New coercion hole:" (ppr u)
+newCoercionHole :: TcPredType -> TcM CoercionHole
+newCoercionHole pred_ty
+  = do { co_var <- newEvVar pred_ty
+       ; traceTc "New coercion hole:" (ppr co_var)
        ; ref <- newMutVar Nothing
-       ; return $ CoercionHole u ref }
+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }
 
 -- | Put a value in a coercion hole
 fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
-fillCoercionHole (CoercionHole u ref) co
+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co
   = do {
 #if defined(DEBUG)
        ; cts <- readTcRef ref
        ; whenIsJust cts $ \old_co ->
-         pprPanic "Filling a filled coercion hole" (ppr u $$ ppr co $$ ppr old_co)
+         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
 #endif
-       ; traceTc "Filling coercion hole" (ppr u <+> text ":=" <+> ppr co)
+       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)
        ; writeTcRef ref (Just co) }
 
 -- | Is a coercion hole filled in?
 isFilledCoercionHole :: CoercionHole -> TcM Bool
-isFilledCoercionHole (CoercionHole _ ref) = isJust <$> readTcRef ref
+isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref
 
 -- | Retrieve the contents of a coercion hole. Panics if the hole
 -- is unfilled
@@ -286,30 +301,35 @@ unpackCoercionHole hole
 
 -- | Retrieve the contents of a coercion hole, if it is filled
 unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
-unpackCoercionHole_maybe (CoercionHole _ ref) = readTcRef ref
+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
 
 -- | Check that a coercion is appropriate for filling a hole. (The hole
--- itself is needed only for printing. NB: This must be /lazy/ in the coercion,
--- as it's used in TcHsSyn in the presence of knots.
+-- itself is needed only for printing.
 -- Always returns the checked coercion, but this return value is necessary
 -- so that the input coercion is forced only when the output is forced.
-checkCoercionHole :: Coercion -> CoercionHole -> Role -> Type -> Type -> TcM Coercion
-checkCoercionHole co h r t1 t2
--- co is already zonked, but t1 and t2 might not be
+checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
+checkCoercionHole cv co
   | debugIsOn
-  = do { t1 <- zonkTcType t1
-       ; t2 <- zonkTcType t2
-       ; let (Pair _t1 _t2, _role) = coercionKindRole co
+  = do { cv_ty <- zonkTcType (varType cv)
+                  -- co is already zonked, but cv might not be
        ; return $
-         ASSERT2( t1 `eqType` _t1 && t2 `eqType` _t2 && r == _role
+         ASSERT2( ok cv_ty
                 , (text "Bad coercion hole" <+>
-                   ppr h <> colon <+> vcat [ ppr _t1, ppr _t2, ppr _role
-                                           , ppr co, ppr t1, ppr t2
-                                           , ppr r ]) )
+                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
+                                            , ppr cv_ty ]) )
          co }
   | otherwise
   = return co
 
+  where
+    (Pair t1 t2, role) = coercionKindRole co
+    ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty
+             =  t1 `eqType` cv_t1
+             && t2 `eqType` cv_t2
+             && role == eqRelRole cv_rel
+             | otherwise
+             = False
+
 {-
 ************************************************************************
 *
@@ -499,13 +519,25 @@ tcInstSkolTyVars' overlappable subst tvs
        ; lvl <- getTcLevel
        ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs }
 
-mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyVarMaker
-mkTcSkolTyVar lvl loc overlappable
-  = \ uniq old_name kind -> mkTcTyVar (mkInternalName uniq (getOccName old_name) loc)
-                                      kind details
+mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyCoVarMaker gbl lcl
+-- Allocates skolems whose level is ONE GREATER THAN the passed-in tc_lvl
+-- See Note [Skolem level allocation]
+mkTcSkolTyVar tc_lvl loc overlappable old_name kind
+  = do { uniq <- newUnique
+       ; let name = mkInternalName uniq (getOccName old_name) loc
+       ; return (mkTcTyVar name kind details) }
   where
-    details = SkolemTv (pushTcLevel lvl) overlappable
-              -- NB: skolems bump the level
+    details = SkolemTv (pushTcLevel tc_lvl) overlappable
+              -- pushTcLevel: see Note [Skolem level allocation]
+
+{- Note [Skolem level allocation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We generally allocate skolems /before/ calling pushLevelAndCaptureConstraints.
+So we want their level to the level of the soon-to-be-created implication,
+which has a level one higher than the current level.  Hence the pushTcLevel.
+It feels like a slight hack.  Applies also to vanillaSkolemTv.
+
+-}
 
 ------------------
 freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])
@@ -514,31 +546,36 @@ freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])
 -- Used in FamInst.newFamInst, and Inst.newClsInst
 freshenTyVarBndrs = instSkolTyCoVars mk_tv
   where
-    mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind
+    mk_tv old_name kind
+       = do { uniq <- newUnique
+            ; return (mkTyVar (setNameUnique old_name uniq) kind) }
 
 freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar])
 -- ^ Give fresh uniques to a bunch of CoVars
 -- Used in FamInst.newFamInst
 freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst
   where
-    mk_cv uniq old_name kind = mkCoVar (setNameUnique old_name uniq) kind
+    mk_cv old_name kind
+      = do { uniq <- newUnique
+           ; return (mkCoVar (setNameUnique old_name uniq) kind) }
 
 ------------------
-type TcTyVarMaker = Unique -> Name -> Kind -> TyCoVar
-instSkolTyCoVars :: TcTyVarMaker -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])
+type TcTyCoVarMaker gbl lcl = Name -> Kind -> TcRnIf gbl lcl TyCoVar
+     -- The TcTyCoVarMaker should make a fresh Name, based on the old one
+     -- Freshness is critical. See Note [Skolems in zonkSyntaxExpr] in TcHsSyn
+
+instSkolTyCoVars :: TcTyCoVarMaker gbl lcl -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])
 instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst
 
-instSkolTyCoVarsX :: TcTyVarMaker
+instSkolTyCoVarsX :: TcTyCoVarMaker gbl lcl
                   -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])
 instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv)
 
-instSkolTyCoVarX :: TcTyVarMaker
+instSkolTyCoVarX :: TcTyCoVarMaker gbl lcl
                  -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar)
 instSkolTyCoVarX mk_tcv subst tycovar
-  = do  { uniq <- newUnique  -- using a new unique is critical. See
-                             -- Note [Skolems in zonkSyntaxExpr] in TcHsSyn
-        ; let new_tcv = mk_tcv uniq old_name kind
-              subst1 | isTyVar new_tcv
+  = do  { new_tcv <- mk_tcv old_name kind
+        ; let subst1 | isTyVar new_tcv
                      = extendTvSubstWithClone subst tycovar new_tcv
                      | otherwise
                      = extendCvSubstWithClone subst tycovar new_tcv
@@ -551,9 +588,10 @@ newFskTyVar :: TcType -> TcM TcTyVar
 newFskTyVar fam_ty
   = do { uniq <- newUnique
        ; ref  <- newMutVar Flexi
+       ; tclvl <- getTcLevel
        ; let details = MetaTv { mtv_info  = FlatSkolTv
                               , mtv_ref   = ref
-                              , mtv_tclvl = fmvTcLevel }
+                              , mtv_tclvl = tclvl }
              name = mkMetaTyVarName uniq (fsLit "fsk")
        ; return (mkTcTyVar name (typeKind fam_ty) details) }
 
@@ -581,16 +619,40 @@ instead of the buggous
 ************************************************************************
 -}
 
-mkMetaTyVarName :: Unique -> FastString -> Name
--- Makes a /System/ Name, which is eagerly eliminated by
--- the unifier; see TcUnify.nicer_to_update_tv1, and
--- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)
-mkMetaTyVarName uniq str = mkSysTvName uniq str
+{-
+Note [TyVarTv]
+~~~~~~~~~~~~
+
+A TyVarTv can unify with type *variables* only, including other TyVarTvs and
+skolems. Sometimes, they can unify with type variables that the user would
+rather keep distinct; see #11203 for an example.  So, any client of this
+function needs to either allow the TyVarTvs to unify with each other or check
+that they don't (say, with a call to findDubTyVarTvs).
+
+Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in
+patterns, to make sure these type variables only refer to other type variables,
+but this restriction was dropped, and ScopedTypeVariables can now refer to full
+types (GHC Proposal 29).
+
+The remaining uses of newTyVarTyVars are
+* in kind signatures, see Note [Kind generalisation and TyVarTvs]
+  and Note [Use TyVarTvs in kind-checking pass]
+* in partial type signatures, see Note [Quantified variables in partial type signatures]
+-}
 
-newSigTyVar :: Name -> Kind -> TcM TcTyVar
-newSigTyVar name kind
-  = do { details <- newMetaDetails SigTv
-       ; return (mkTcTyVar name kind details) }
+-- see Note [TyVarTv]
+newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
+newTyVarTyVar name kind
+  = do { details <- newMetaDetails TyVarTv
+       ; let tyvar = mkTcTyVar name kind details
+       ; traceTc "newTyVarTyVar" (ppr tyvar)
+       ; return tyvar }
+
+
+-- makes a new skolem tv
+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
+newSkolemTyVar name kind = do { lvl <- getTcLevel
+                              ; return (mkTcTyVar name kind (SkolemTv lvl False)) }
 
 newFmvTyVar :: TcType -> TcM TcTyVar
 -- Very like newMetaTyVar, except sets mtv_tclvl to one less
@@ -598,9 +660,10 @@ newFmvTyVar :: TcType -> TcM TcTyVar
 newFmvTyVar fam_ty
   = do { uniq <- newUnique
        ; ref  <- newMutVar Flexi
+       ; tclvl <- getTcLevel
        ; let details = MetaTv { mtv_info  = FlatMetaTv
                               , mtv_ref   = ref
-                              , mtv_tclvl = fmvTcLevel }
+                              , mtv_tclvl = tclvl }
              name = mkMetaTyVarName uniq (fsLit "s")
        ; return (mkTcTyVar name (typeKind fam_ty) details) }
 
@@ -621,7 +684,9 @@ cloneMetaTyVar tv
               details' = case tcTyVarDetails tv of
                            details@(MetaTv {}) -> details { mtv_ref = ref }
                            _ -> pprPanic "cloneMetaTyVar" (ppr tv)
-        ; return (mkTcTyVar name' (tyVarKind tv) details') }
+              tyvar = mkTcTyVar name' (tyVarKind tv) details'
+        ; traceTc "cloneMetaTyVar" (ppr tyvar)
+        ; return tyvar }
 
 -- Works for both type and kind variables
 readMetaTyVar :: TyVar -> TcM MetaDetails
@@ -680,15 +745,18 @@ writeMetaTyVarRef tyvar ref ty
   = do { meta_details <- readMutVar ref;
        -- Zonk kinds to allow the error check to work
        ; zonked_tv_kind <- zonkTcType tv_kind
-       ; zonked_ty_kind <- zonkTcType ty_kind
-       ; let kind_check_ok = isPredTy tv_kind  -- Don't check kinds for updates
-                                               -- to coercion variables
+       ; zonked_ty      <- zonkTcType ty
+       ; let zonked_ty_kind = typeKind zonked_ty  -- need to zonk even before typeKind;
+                                                  -- otherwise, we can panic in piResultTy
+             kind_check_ok = tcIsConstraintKind zonked_tv_kind
                           || tcEqKind zonked_ty_kind zonked_tv_kind
+             -- Hack alert! tcIsConstraintKind: see TcHsType
+             -- Note [Extra-constraint holes in partial type signatures]
 
              kind_msg = hang (text "Ill-kinded update to meta tyvar")
                            2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
                               <+> text ":="
-                              <+> ppr ty <+> text "::" <+> (ppr ty_kind $$ ppr zonked_ty_kind) )
+                              <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
 
        ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
 
@@ -706,13 +774,11 @@ writeMetaTyVarRef tyvar ref ty
        ; writeMutVar ref (Indirect ty) }
   where
     tv_kind = tyVarKind tyvar
-    ty_kind = typeKind ty
 
     tv_lvl = tcTyVarLevel tyvar
     ty_lvl = tcTypeLevel ty
 
-    level_check_ok = isFlattenTyVar tyvar
-                  || not (ty_lvl `strictlyDeeperThan` tv_lvl)
+    level_check_ok  = not (ty_lvl `strictlyDeeperThan` tv_lvl)
     level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
 
     double_upd_msg details = hang (text "Double update of meta tyvar")
@@ -734,14 +800,6 @@ See Note [TcLevel assignment] in TcType.
 % Generating fresh variables for pattern match check
 -}
 
--- UNINSTANTIATED VERSION OF tcInstSkolTyCoVars
-genInstSkolTyVarsX :: SrcSpan -> TCvSubst -> [TyVar]
-                   -> TcRnIf gbl lcl (TCvSubst, [TcTyVar])
--- Precondition: tyvars should be scoping-ordered
--- see Note [Kind substitution when instantiating]
--- Get the location from the monad; this is a complete freshening operation
-genInstSkolTyVarsX loc subst tvs
-  = instSkolTyCoVarsX (mkTcSkolTyVar topTcLevel loc False) subst tvs
 
 {-
 ************************************************************************
@@ -764,6 +822,20 @@ coercion variables, except for the special case of the promoted Eq#. But,
 that can't ever appear in user code, so we're safe!
 -}
 
+newTauTyVar :: Name -> Kind -> TcM TcTyVar
+newTauTyVar name kind
+  = do { details <- newMetaDetails TauTv
+       ; let tyvar = mkTcTyVar name kind details
+       ; traceTc "newTauTyVar" (ppr tyvar)
+       ; return tyvar }
+
+
+mkMetaTyVarName :: Unique -> FastString -> Name
+-- Makes a /System/ Name, which is eagerly eliminated by
+-- the unifier; see TcUnify.nicer_to_update_tv1, and
+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)
+mkMetaTyVarName uniq str = mkSystemName uniq (mkTyVarOccFS str)
+
 newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
 -- Make a new meta tyvar out of thin air
 newAnonMetaTyVar meta_info kind
@@ -773,9 +845,28 @@ newAnonMetaTyVar meta_info kind
                         TauTv       -> fsLit "t"
                         FlatMetaTv  -> fsLit "fmv"
                         FlatSkolTv  -> fsLit "fsk"
-                        SigTv       -> fsLit "a"
+                        TyVarTv      -> fsLit "a"
         ; details <- newMetaDetails meta_info
-        ; return (mkTcTyVar name kind details) }
+        ; let tyvar = mkTcTyVar name kind details
+        ; traceTc "newAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
+-- Same as newAnonMetaTyVar, but use a supplied TyVar as the source of the print-name
+cloneAnonMetaTyVar info tv kind
+  = do  { uniq    <- newUnique
+        ; details <- newMetaDetails info
+        ; let name = mkSystemName uniq (getOccName tv)
+                       -- See Note [Name of an instantiated type variable]
+              tyvar = mkTcTyVar name kind details
+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+{- Note [Name of an instantiated type variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we give a unification variable a System Name, which
+influences the way it is tidied; see TypeRep.tidyTyVarBndr.
+-}
 
 newFlexiTyVar :: Kind -> TcM TcTyVar
 newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
@@ -800,8 +891,8 @@ newOpenFlexiTyVarTy
   = do { kind <- newOpenTypeKind
        ; newFlexiTyVarTy kind }
 
-newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
-newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst
+newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
 
 newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
 -- Instantiate with META type variables
@@ -822,9 +913,9 @@ newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
 -- Just like newMetaTyVars, but start with an existing substitution.
 newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
 
-newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
--- Just like newMetaTyVarX, but make a SigTv
-newMetaSigTyVarX subst tyvar = new_meta_tv_x SigTv subst tyvar
+newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Just like newMetaTyVarX, but make a TyVarTv
+newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar
 
 newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 newWildCardX subst tv
@@ -833,23 +924,20 @@ newWildCardX subst tv
 
 new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 new_meta_tv_x info subst tv
-  = do  { uniq <- newUnique
-        ; details <- newMetaDetails info
-        ; let name   = mkSystemName uniq (getOccName tv)
-                       -- See Note [Name of an instantiated type variable]
-              kind   = substTyUnchecked subst (tyVarKind tv)
-                       -- NOTE: Trac #12549 is fixed so we could use
-                       -- substTy here, but the tc_infer_args problem
-                       -- is not yet fixed so leaving as unchecked for now.
-                       -- OLD NOTE:
-                       -- Unchecked because we call newMetaTyVarX from
-                       -- tcInstBinder, which is called from tc_infer_args
-                       -- which does not yet take enough trouble to ensure
-                       -- the in-scope set is right; e.g. Trac #12785 trips
-                       -- if we use substTy here
-              new_tv = mkTcTyVar name kind details
-              subst1 = extendTvSubstWithClone subst tv new_tv
+  = do  { new_tv <- cloneAnonMetaTyVar info tv substd_kind
+        ; let subst1 = extendTvSubstWithClone subst tv new_tv
         ; return (subst1, new_tv) }
+  where
+    substd_kind = substTyUnchecked subst (tyVarKind tv)
+      -- NOTE: Trac #12549 is fixed so we could use
+      -- substTy here, but the tc_infer_args problem
+      -- is not yet fixed so leaving as unchecked for now.
+      -- OLD NOTE:
+      -- Unchecked because we call newMetaTyVarX from
+      -- tcInstTyBinder, which is called from tcInferApps
+      -- which does not yet take enough trouble to ensure
+      -- the in-scope set is right; e.g. Trac #12785 trips
+      -- if we use substTy here
 
 newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
 newMetaTyVarTyAtLevel tc_lvl kind
@@ -861,12 +949,7 @@ newMetaTyVarTyAtLevel tc_lvl kind
                                , mtv_tclvl = tc_lvl }
         ; return (mkTyVarTy (mkTcTyVar name kind details)) }
 
-{- Note [Name of an instantiated type variable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At the moment we give a unification variable a System Name, which
-influences the way it is tidied; see TypeRep.tidyTyVarBndr.
-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
              Quantification
 *                                                                      *
@@ -888,7 +971,7 @@ also free in the type.  Eg
      Typeable k (a::k)
 has free vars {k,a}.  But the type (see Trac #7916)
     (f::k->*) (a::k)
-has free vars {f,a}, but we must add 'k' as well! Hence step (3).
+has free vars {f,a}, but we must add 'k' as well! Hence step (2).
 
 * This function distinguishes between dependent and non-dependent
   variables only to keep correct defaulting behavior with -XNoPolyKinds.
@@ -923,15 +1006,11 @@ quantifyTyVars
 
 quantifyTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })
   = do { traceTc "quantifyTyVars" (vcat [ppr dvs, ppr gbl_tvs])
-       ; let all_cvs = filterVarSet isCoVar $ dVarSetToVarSet dep_tkvs
-             dep_kvs = dVarSetElemsWellScoped $
+       ; let dep_kvs = dVarSetElemsWellScoped $
                        dep_tkvs `dVarSetMinusVarSet` gbl_tvs
-                                `dVarSetMinusVarSet` closeOverKinds all_cvs
-                 -- dVarSetElemsWellScoped: put the kind variables into
-                 --    well-scoped order.
-                 --    E.g.  [k, (a::k)] not the other way roud
-                 -- closeOverKinds all_cvs: do not quantify over coercion
-                 --    variables, or any any tvs that a covar depends on
+                       -- dVarSetElemsWellScoped: put the kind variables into
+                       --    well-scoped order.
+                       --    E.g.  [k, (a::k)] not the other way roud
 
              nondep_tvs = dVarSetElems $
                           (nondep_tkvs `minusDVarSet` dep_tkvs)
@@ -954,6 +1033,7 @@ quantifyTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })
        ; poly_kinds  <- xoptM LangExt.PolyKinds
        ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs
        ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs
+       ; let final_qtvs = dep_kvs' ++ nondep_tvs'
            -- Because of the order, any kind variables
            -- mentioned in the kinds of the nondep_tvs'
            -- now refer to the dep_kvs'
@@ -965,13 +1045,21 @@ quantifyTyVars gbl_tvs dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })
                  , text "dep_kvs'" <+> pprTyVars dep_kvs'
                  , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])
 
-       ; return (dep_kvs' ++ nondep_tvs') }
+       -- We should never quantify over coercion variables; check this
+       ; let co_vars = filter isCoVar final_qtvs
+       ; MASSERT2( null co_vars, ppr co_vars )
+
+       ; return final_qtvs }
   where
     -- zonk_quant returns a tyvar if it should be quantified over;
     -- otherwise, it returns Nothing. The latter case happens for
     --    * Kind variables, with -XNoPolyKinds: don't quantify over these
     --    * RuntimeRep variables: we never quantify over these
     zonk_quant default_kind tkv
+      | not (isTyVar tkv)
+      = return Nothing   -- this can happen for a covar that's associated with
+                         -- a coercion hole. Test case: typecheck/should_compile/T2494
+
       | not (isTcTyVar tkv)
       = return (Just tkv)  -- For associated types, we have the class variables
                            -- in scope, and they are TyVars not TcTyVars
@@ -1013,31 +1101,35 @@ defaultTyVar default_kind tv
   | not (isMetaTyVar tv)
   = return False
 
-  | isRuntimeRepVar tv && not_sig_tv  -- We never quantify over a RuntimeRep var
+  | isTyVarTyVar tv
+    -- Do not default TyVarTvs. Doing so would violate the invariants
+    -- on TyVarTvs; see Note [Signature skolems] in TcType.
+    -- Trac #13343 is an example; #14555 is another
+    -- See Note [Kind generalisation and TyVarTvs]
+  = return False
+
+
+  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var
+                        -- unless it is a TyVarTv, handled earlier
   = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
        ; writeMetaTyVar tv liftedRepTy
        ; return True }
 
-  | default_kind && not_sig_tv        -- -XNoPolyKinds and this is a kind var
-  = do { default_kind_var tv          -- so default it to * if possible
+  | default_kind                 -- -XNoPolyKinds and this is a kind var
+  = do { default_kind_var tv     -- so default it to * if possible
        ; return True }
 
   | otherwise
   = return False
 
   where
-    -- Do not default SigTvs. Doing so would violate the invariants
-    -- on SigTvs; see Note [Signature skolems] in TcType.
-    -- Trac #13343 is an example
-    not_sig_tv = not (isSigTyVar tv)
-
     default_kind_var :: TyVar -> TcM ()
        -- defaultKindVar is used exclusively with -XNoPolyKinds
        -- See Note [Defaulting with -XNoPolyKinds]
        -- It takes an (unconstrained) meta tyvar and defaults it.
        -- Works only on vars of type *; for other kinds, it issues an error.
     default_kind_var kv
-      | isStarKind (tyVarKind kv)
+      | isLiftedTypeKind (tyVarKind kv)
       = do { traceTc "Defaulting a kind var to *" (ppr kv)
            ; writeMetaTyVar kv liftedTypeKind }
       | otherwise
@@ -1047,21 +1139,12 @@ defaultTyVar default_kind tv
       where
         (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
 
-skolemiseRuntimeUnk :: TcTyVar -> TcM TyVar
-skolemiseRuntimeUnk tv
-  = skolemise_tv tv RuntimeUnk
-
 skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
-skolemiseUnboundMetaTyVar tv
-  = skolemise_tv tv (SkolemTv (metaTyVarTcLevel tv) False)
-
-skolemise_tv :: TcTyVar -> TcTyVarDetails -> TcM TyVar
 -- We have a Meta tyvar with a ref-cell inside it
--- Skolemise it, so that
---   we are totally out of Meta-tyvar-land
--- We create a skolem TyVar, not a regular TyVar
+-- Skolemise it, so that we are totally out of Meta-tyvar-land
+-- We create a skolem TcTyVar, not a regular TyVar
 --   See Note [Zonking to Skolem]
-skolemise_tv tv details
+skolemiseUnboundMetaTyVar tv
   = ASSERT2( isMetaTyVar tv, ppr tv )
     do  { when debugIsOn (check_empty tv)
         ; span <- getSrcSpanM    -- Get the location from "here"
@@ -1080,6 +1163,7 @@ skolemise_tv tv details
         ; return final_tv }
 
   where
+    details = SkolemTv (metaTyVarTcLevel tv) False
     check_empty tv       -- [Sept 04] Check for non-empty.
       = when debugIsOn $  -- See note [Silly Type Synonym]
         do { cts <- readMetaTyVar tv
@@ -1238,6 +1322,8 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
 -- variables free in anything (term-level or type-level) in scope. We thus
 -- don't have to worry about clashes with things that are not in scope, because
 -- if they are reachable, then they'll be returned here.
+-- NB: This is closed over kinds, so it can return unification variables mentioned
+-- in the kinds of in-scope tyvars.
 tcGetGlobalTyCoVars :: TcM TcTyVarSet
 tcGetGlobalTyCoVars
   = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
@@ -1246,11 +1332,6 @@ tcGetGlobalTyCoVars
        ; writeMutVar gtv_var gbl_tvs'
        ; return gbl_tvs' }
 
--- | Zonk a type without using the smart constructors; the result type
--- is available for inspection within the type-checking knot.
-zonkTcTypeInKnot :: TcType -> TcM TcType
-zonkTcTypeInKnot = mapType (zonkTcTypeMapper { tcm_smart = False }) ()
-
 zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
 -- Zonk a type and take its free variables
 -- With kind polymorphism it can be essential to zonk *first*
@@ -1258,20 +1339,17 @@ zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
 --    forall k1. forall (a:k2). a
 -- where k2:=k1 is in the substitution.  We don't want
 -- k2 to look free in this type!
--- NB: This might be called from within the knot, so don't use
--- smart constructors. See Note [Zonking within the knot] in TcHsType
 zonkTcTypeAndFV ty
-  = tyCoVarsOfTypeDSet <$> zonkTcTypeInKnot ty
+  = tyCoVarsOfTypeDSet <$> zonkTcType ty
 
 -- | Zonk a type and call 'candidateQTyVarsOfType' on it.
--- Works within the knot.
 zonkTcTypeAndSplitDepVars :: TcType -> TcM CandidatesQTvs
 zonkTcTypeAndSplitDepVars ty
-  = candidateQTyVarsOfType <$> zonkTcTypeInKnot ty
+  = candidateQTyVarsOfType <$> zonkTcType ty
 
 zonkTcTypesAndSplitDepVars :: [TcType] -> TcM CandidatesQTvs
 zonkTcTypesAndSplitDepVars tys
-  = candidateQTyVarsOfTypes <$> mapM zonkTcTypeInKnot tys
+  = candidateQTyVarsOfTypes <$> mapM zonkTcType tys
 
 zonkTyCoVar :: TyCoVar -> TcM TcType
 -- Works on TyVars and TcTyVars
@@ -1340,11 +1418,10 @@ zonkWC :: WantedConstraints -> TcM WantedConstraints
 zonkWC wc = zonkWCRec wc
 
 zonkWCRec :: WantedConstraints -> TcM WantedConstraints
-zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
+zonkWCRec (WC { wc_simple = simple, wc_impl = implic })
   = do { simple' <- zonkSimples simple
        ; implic' <- mapBagM zonkImplication implic
-       ; insol'  <- zonkSimples insol
-       ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) }
+       ; return (WC { wc_simple = simple', wc_impl = implic' }) }
 
 zonkSimples :: Cts -> TcM Cts
 zonkSimples cts = do { cts' <- mapBagM zonkCt' cts
@@ -1355,10 +1432,12 @@ zonkCt' :: Ct -> TcM Ct
 zonkCt' ct = zonkCt ct
 
 {- Note [zonkCt behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 zonkCt tries to maintain the canonical form of a Ct.  For example,
   - a CDictCan should stay a CDictCan;
   - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).
   - a CHoleCan should stay a CHoleCan
+  - a CIrredCan should stay a CIrredCan with its cc_insol flag intact
 
 Why?, for example:
 - For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the
@@ -1369,21 +1448,27 @@ Why?, for example:
 
 - For CHoleCan, once we forget that it's a hole, we can never recover that info.
 
+- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
+
 NB: we do not expect to see any CFunEqCans, because zonkCt is only
 called on unflattened constraints.
+
 NB: Constraints are always re-flattened etc by the canonicaliser in
 @TcCanonical@ even if they come in as CDictCan. Only canonical constraints that
 are actually in the inert set carry all the guarantees. So it is okay if zonkCt
 creates e.g. a CDictCan where the cc_tyars are /not/ function free.
 -}
+
 zonkCt :: Ct -> TcM Ct
 zonkCt ct@(CHoleCan { cc_ev = ev })
   = do { ev' <- zonkCtEvidence ev
        ; return $ ct { cc_ev = ev' } }
+
 zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
   = do { ev'   <- zonkCtEvidence ev
        ; args' <- mapM zonkTcType args
        ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+
 zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })
   = do { ev'    <- zonkCtEvidence ev
        ; tv_ty' <- zonkTcTyVar tv
@@ -1393,11 +1478,16 @@ zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })
                                       , cc_tyvar = tv'
                                       , cc_rhs   = rhs' } }
            Nothing  -> return (mkNonCanonical ev') }
+
+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag
+  = do { ev' <- zonkCtEvidence ev
+       ; return (ct { cc_ev = ev' }) }
+
 zonkCt ct
   = ASSERT( not (isCFunEqCan ct) )
   -- We do not expect to see any CFunEqCans, because zonkCt is only called on
   -- unflattened constraints.
-    do { fl' <- zonkCtEvidence (cc_ev ct)
+    do { fl' <- zonkCtEvidence (ctEvidence ct)
        ; return (mkNonCanonical fl') }
 
 zonkCtEvidence :: CtEvidence -> TcM CtEvidence
@@ -1441,7 +1531,10 @@ zonkId id
   = do { ty' <- zonkTcType (idType id)
        ; return (Id.setIdType id ty') }
 
--- | A suitable TyCoMapper for zonking a type inside the knot, and
+zonkCoVar :: CoVar -> TcM CoVar
+zonkCoVar = zonkId
+
+-- | A suitable TyCoMapper for zonking a type during type-checking,
 -- before all metavars are filled in.
 zonkTcTypeMapper :: TyCoMapper () TcM
 zonkTcTypeMapper = TyCoMapper
@@ -1449,19 +1542,17 @@ zonkTcTypeMapper = TyCoMapper
   , tcm_tyvar = const zonkTcTyVar
   , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
   , tcm_hole  = hole
-  , tcm_tybinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv }
+  , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv
+  , tcm_tycon = return }
   where
-    hole :: () -> CoercionHole -> Role -> Type -> Type
-         -> TcM Coercion
-    hole _ h r t1 t2
-      = do { contents <- unpackCoercionHole_maybe h
+    hole :: () -> CoercionHole -> TcM Coercion
+    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+      = do { contents <- readTcRef ref
            ; case contents of
-               Just co -> do { co <- zonkCo co
-                             ; checkCoercionHole co h r t1 t2 }
-               Nothing -> do { t1 <- zonkTcType t1
-                             ; t2 <- zonkTcType t2
-                             ; return $ mkHoleCo h r t1 t2 } }
-
+               Just co -> do { co' <- zonkCo co
+                             ; checkCoercionHole cv co' }
+               Nothing -> do { cv' <- zonkCoVar cv
+                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }
 
 -- For unbound, mutable tyvars, zonkType uses the function given to it
 -- For tyvars bound at a for-all, zonkType zonks them to an immutable
@@ -1474,19 +1565,25 @@ zonkCo :: Coercion -> TcM Coercion
 zonkCo = mapCoercion zonkTcTypeMapper ()
 
 zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar
--- A tyvar binder is never a unification variable (MetaTv),
--- rather it is always a skolems.  BUT it may have a kind
+-- A tyvar binder is never a unification variable (TauTv),
+-- rather it is always a skolem. It *might* be a TyVarTv.
+-- (Because non-CUSK type declarations use TyVarTvs.)
+-- Regardless, it may have a kind
 -- that has not yet been zonked, and may include kind
 -- unification variables.
 zonkTcTyCoVarBndr tyvar
+  | isTyVarTyVar tyvar
+  = tcGetTyVar "zonkTcTyCoVarBndr TyVarTv" <$> zonkTcTyVar tyvar
+
+  | otherwise
     -- can't use isCoVar, because it looks at a TyCon. Argh.
   = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar )
     updateTyVarKindM zonkTcType tyvar
 
-zonkTcTyVarBinder :: TyVarBndr TcTyVar vis -> TcM (TyVarBndr TcTyVar vis)
-zonkTcTyVarBinder (TvBndr tv vis)
+zonkTcTyVarBinder :: VarBndr TcTyVar vis -> TcM (VarBndr TcTyVar vis)
+zonkTcTyVarBinder (Bndr tv vis)
   = do { tv' <- zonkTcTyCoVarBndr tv
-       ; return (TvBndr tv' vis) }
+       ; return (Bndr tv' vis) }
 
 zonkTcTyVar :: TcTyVar -> TcM TcType
 -- Simply look through all Flexis
@@ -1499,7 +1596,10 @@ zonkTcTyVar tv
          -> do { cts <- readMutVar ref
                ; case cts of
                     Flexi       -> zonk_kind_and_return
-                    Indirect ty -> zonkTcType ty }
+                    Indirect ty -> do { zty <- zonkTcType ty
+                                      ; writeTcRef ref (Indirect zty)
+                                        -- See Note [Sharing in zonking]
+                                      ; return zty } }
 
   | otherwise -- coercion variable
   = zonk_kind_and_return
@@ -1508,13 +1608,43 @@ zonkTcTyVar tv
                               ; return (mkTyVarTy z_tv) }
 
 -- Variant that assumes that any result of zonking is still a TyVar.
--- Should be used only on skolems and SigTvs
-zonkTcTyVarToTyVar :: TcTyVar -> TcM TcTyVar
+-- Should be used only on skolems and TyVarTvs
+zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
 zonkTcTyVarToTyVar tv
   = do { ty <- zonkTcTyVar tv
-       ; return (tcGetTyVar "zonkTcTyVarToVar" ty) }
+       ; let tv' = case tcGetTyVar_maybe ty of
+                     Just tv' -> tv'
+                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"
+                                          (ppr tv $$ ppr ty)
+       ; return tv' }
+
+zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)]
+zonkTyVarTyVarPairs prs
+  = mapM do_one prs
+  where
+    do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv
+                         ; return (nm, tv') }
+
+{- Note [Sharing in zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   alpha :-> beta :-> gamma :-> ty
+where the ":->" means that the unification variable has been
+filled in with Indirect. Then when zonking alpha, it'd be nice
+to short-circuit beta too, so we end up with
+   alpha :-> zty
+   beta  :-> zty
+   gamma :-> zty
+where zty is the zonked version of ty.  That way, if we come across
+beta later, we'll have less work to do.  (And indeed the same for
+alpha.)
+
+This is easily achieved: just overwrite (Indirect ty) with (Indirect
+zty).  Non-systematic perf comparisons suggest that this is a modest
+win.
+
+But c.f Note [Sharing when zonking to Type] in TcHsSyn.
 
-{-
 %************************************************************************
 %*                                                                      *
                  Tidying
@@ -1526,17 +1656,12 @@ zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
                            ; return (tidyOpenType env ty') }
 
--- | Make an 'ErrorThing' storing a type.
-mkTypeErrorThing :: TcType -> ErrorThing
-mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ repSplitAppTys ty)
-                                 zonkTidyTcType
-   -- NB: Use *rep*splitAppTys, else we get #11313
-
--- | Make an 'ErrorThing' storing a type, with some extra args known about
-mkTypeErrorThingArgs :: TcType -> Int -> ErrorThing
-mkTypeErrorThingArgs ty num_args
-  = ErrorThing ty (Just $ (length $ snd $ repSplitAppTys ty) + num_args)
-               zonkTidyTcType
+zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
+zonkTidyTcTypes = zonkTidyTcTypes' []
+  where zonkTidyTcTypes' zs env [] = return (env, reverse zs)
+        zonkTidyTcTypes' zs env (ty:tys)
+          = do { (env', ty') <- zonkTidyTcType env ty
+               ; zonkTidyTcTypes' (ty':zs) env' tys }
 
 zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
 zonkTidyOrigin env (GivenOrigin skol_info)
@@ -1544,14 +1669,11 @@ zonkTidyOrigin env (GivenOrigin skol_info)
        ; let skol_info2 = tidySkolemInfo env skol_info1
        ; return (env, GivenOrigin skol_info2) }
 zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act
-                                      , uo_expected = exp
-                                      , uo_thing    = m_thing })
+                                      , uo_expected = exp })
   = do { (env1, act') <- zonkTidyTcType env  act
        ; (env2, exp') <- zonkTidyTcType env1 exp
-       ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing
-       ; return ( env3, orig { uo_actual   = act'
-                             , uo_expected = exp'
-                             , uo_thing    = m_thing' }) }
+       ; return ( env2, orig { uo_actual   = act'
+                             , uo_expected = exp' }) }
 zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)
   = do { (env1, ty1')   <- zonkTidyTcType env  ty1
        ; (env2, m_ty2') <- case m_ty2 of
@@ -1570,14 +1692,6 @@ zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)
        ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }
 zonkTidyOrigin env orig = return (env, orig)
 
-zonkTidyErrorThing :: TidyEnv -> Maybe ErrorThing
-                   -> TcM (TidyEnv, Maybe ErrorThing)
-zonkTidyErrorThing env (Just (ErrorThing thing n_args zonker))
-  = do { (env', thing') <- zonker env thing
-       ; return (env', Just $ ErrorThing thing' n_args zonker) }
-zonkTidyErrorThing env Nothing
-  = return (env, Nothing)
-
 ----------------
 tidyCt :: TidyEnv -> Ct -> Ct
 -- Used only in error reporting
@@ -1617,11 +1731,11 @@ tidySigSkol :: TidyEnv -> UserTypeCtxt
 tidySigSkol env cx ty tv_prs
   = SigSkol cx (tidy_ty env ty) tv_prs'
   where
-    tv_prs' = mapSnd (tidyTyVarOcc env) tv_prs
+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs
     inst_env = mkNameEnv tv_prs'
 
-    tidy_ty env (ForAllTy (TvBndr tv vis) ty)
-      = ForAllTy (TvBndr tv' vis) (tidy_ty env' ty)
+    tidy_ty env (ForAllTy (Bndr tv vis) ty)
+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)
       where
         (env', tv') = tidy_tv_bndr env tv
 
@@ -1630,13 +1744,13 @@ tidySigSkol env cx ty tv_prs
 
     tidy_ty env ty = tidyType env ty
 
-    tidy_tv_bndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
     tidy_tv_bndr env@(occ_env, subst) tv
       | Just tv' <- lookupNameEnv inst_env (tyVarName tv)
       = ((occ_env, extendVarEnv subst tv tv'), tv')
 
       | otherwise
-      = tidyTyCoVarBndr env tv
+      = tidyVarBndr env tv
 
 -------------------------------------------------------------------------
 {-
@@ -1684,8 +1798,8 @@ formatLevPolyErr :: Type  -- levity-polymorphic type
                  -> SDoc
 formatLevPolyErr ty
   = hang (text "A levity-polymorphic type is not allowed here:")
-       2 (vcat [ text "Type:" <+> ppr tidy_ty
-               , text "Kind:" <+> ppr tidy_ki ])
+       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
+               , text "Kind:" <+> pprWithTYPE tidy_ki ])
   where
     (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
     tidy_ki             = tidyType tidy_env (typeKind ty)
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index 8207169d41..4ddf862bf7 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -19,6 +19,8 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
                    tcDoStmt, tcGuardStmt
        ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
@@ -99,10 +101,11 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
     arity = matchGroupArity matches
     herald = text "The equation(s) for"
              <+> quotes (ppr fun_name) <+> text "have"
-    match_ctxt = MC { mc_what = FunRhs fn Prefix strictness, mc_body = tcBody }
+    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+    match_ctxt = MC { mc_what = what, mc_body = tcBody }
     strictness
       | [L _ match] <- unLoc $ mg_alts matches
-      , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
+      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
       = SrcStrict
       | otherwise
       = NoSrcStrict
@@ -217,9 +220,9 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
        ; pat_tys  <- mapM readExpType pat_tys
        ; rhs_ty   <- readExpType rhs_ty
        ; return (MG { mg_alts = L l matches'
-                    , mg_arg_tys = pat_tys
-                    , mg_res_ty = rhs_ty
+                    , mg_ext = MatchGroupTc pat_tys rhs_ty
                     , mg_origin = origin }) }
+tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"
 
 -------------
 tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
@@ -231,18 +234,15 @@ tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
 tcMatch ctxt pat_tys rhs_ty match
   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
   where
-    tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss)
+    tc_match ctxt pat_tys rhs_ty
+             match@(Match { m_pats = pats, m_grhss = grhss })
       = add_match_ctxt match $
         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
-                                tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
-           ; return (Match (mc_what ctxt) pats' Nothing grhss') }
-
-    tc_grhss ctxt Nothing grhss rhs_ty
-      = tcGRHSs ctxt grhss rhs_ty       -- No result signature
-
-        -- Result type sigs are no longer supported
-    tc_grhss _ (Just {}) _ _
-      = panic "tc_ghrss"        -- Rejected by renamer
+                                tcGRHSs ctxt grhss rhs_ty
+           ; return (Match { m_ext = noExt
+                           , m_ctxt = mc_what ctxt, m_pats = pats'
+                           , m_grhss = grhss' }) }
+    tc_match  _ _ _ (XMatch _) = panic "tcMatch"
 
         -- For (\x -> e), tcExpr has already said "In the expression \x->e"
         -- so we don't want to add "In the lambda abstraction \x->e"
@@ -261,24 +261,26 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
 -- We used to force it to be a monotype when there was more than one guard
 -- but we don't need to do that any more
 
-tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty
+tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
   = do  { (binds', grhss')
             <- tcLocalBinds binds $
                mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 
-        ; return (GRHSs grhss' (L l binds')) }
+        ; return (GRHSs noExt grhss' (L l binds')) }
+tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"
 
 -------------
 tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
        -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
 
-tcGRHS ctxt res_ty (GRHS guards rhs)
+tcGRHS ctxt res_ty (GRHS _ guards rhs)
   = do  { (guards', rhs')
             <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
                mc_body ctxt rhs
-        ; return (GRHS guards' rhs') }
+        ; return (GRHS noExt guards' rhs') }
   where
     stmt_ctxt  = PatGuard (mc_what ctxt)
+tcGRHS _ _ (XGRHS _) = panic "tcGRHS"
 
 {-
 ************************************************************************
@@ -298,30 +300,22 @@ tcDoStmts ListComp (L l stmts) res_ty
         ; let list_ty = mkListTy elt_ty
         ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
                             (mkCheckExpType elt_ty)
-        ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) }
-
-tcDoStmts PArrComp (L l stmts) res_ty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (co, elt_ty) <- matchExpectedPArrTy res_ty
-        ; let parr_ty = mkPArrTy elt_ty
-        ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
-                            (mkCheckExpType elt_ty)
-        ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) }
+        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
 
 tcDoStmts DoExpr (L l stmts) res_ty
   = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
         ; res_ty <- readExpType res_ty
-        ; return (HsDo DoExpr (L l stmts') res_ty) }
+        ; return (HsDo res_ty DoExpr (L l stmts')) }
 
 tcDoStmts MDoExpr (L l stmts) res_ty
   = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
         ; res_ty <- readExpType res_ty
-        ; return (HsDo MDoExpr (L l stmts') res_ty) }
+        ; return (HsDo res_ty MDoExpr (L l stmts')) }
 
 tcDoStmts MonadComp (L l stmts) res_ty
   = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
         ; res_ty <- readExpType res_ty
-        ; return (HsDo MonadComp (L l stmts') res_ty) }
+        ; return (HsDo res_ty MonadComp (L l stmts')) }
 
 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
@@ -374,11 +368,11 @@ tcStmtsAndThen _ _ [] res_ty thing_inside
         ; return ([], thing) }
 
 -- LetStmts are handled uniformly, regardless of context
-tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts)
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
                                                              res_ty thing_inside
   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
               tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
-        ; return (L loc (LetStmt (L l binds')) : stmts', thing) }
+        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
 
 -- Don't set the error context for an ApplicativeStmt.  It ought to be
 -- possible to do this with a popErrCtxt in the tcStmt case for
@@ -407,12 +401,12 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 ---------------------------------------------------
 
 tcGuardStmt :: TcExprStmtChecker
-tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside
+tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
   = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
         ; thing  <- thing_inside res_ty
-        ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
+        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
 
-tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
+tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
   = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs
                                    -- Stmt has a context already
         ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
@@ -425,29 +419,28 @@ tcGuardStmt _ stmt _ _
 
 
 ---------------------------------------------------
---           List comprehensions and PArrays
+--           List comprehensions
 --               (no rebindable syntax)
 ---------------------------------------------------
 
 -- Dealt with separately, rather than by tcMcStmt, because
---   a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
---   b) We have special desugaring rules for list comprehensions,
+--   a) We have special desugaring rules for list comprehensions,
 --      which avoid creating intermediate lists.  They in turn
 --      assume that the bind/return operations are the regular
 --      polymorphic ones, and in particular don't have any
 --      coercion matching stuff in them.  It's hard to avoid the
 --      potential for non-trivial coercions in tcMcStmt
 
-tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
+tcLcStmt :: TyCon       -- The list type constructor ([])
          -> TcExprStmtChecker
 
-tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside
+tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
   = do { body' <- tcMonoExprNC body elt_ty
        ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
-       ; return (LastStmt body' noret noSyntaxExpr, thing) }
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
 
 -- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
         ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
@@ -455,28 +448,29 @@ tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside
         ; return (mkTcBindStmt pat' rhs', thing) }
 
 -- A boolean guard
-tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside
+tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
   = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)
         ; thing <- thing_inside elt_ty
-        ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
+        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- ParStmt: See notes with tcMcStmt
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
   = do  { (pairs', thing) <- loop bndr_stmts_s
-        ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) }
+        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
   where
     -- loop :: [([LStmt GhcRn], [GhcRn])]
     --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
     loop [] = do { thing <- thing_inside elt_ty
                  ; return ([], thing) }         -- matching in the branches
 
-    loop (ParStmtBlock stmts names _ : pairs)
+    loop (ParStmtBlock x stmts names _ : pairs)
       = do { (stmts', (ids, pairs', thing))
                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
                    do { ids <- tcLookupLocalIds names
                       ; (pairs', thing) <- loop pairs
                       ; return (ids, pairs', thing) }
-           ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) }
+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+    loop (XParStmtBlock{}:_) = panic "tcLcStmt"
 
 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                               , trS_bndrs =  bindersMap
@@ -538,7 +532,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                            , trS_ret = noSyntaxExpr
                            , trS_bind = noSyntaxExpr
                            , trS_fmap = noExpr
-                           , trS_bind_arg_ty = unitTy
+                           , trS_ext = unitTy
                            , trS_form = form }, thing) }
 
 tcLcStmt _ _ stmt _ _
@@ -552,13 +546,13 @@ tcLcStmt _ _ stmt _ _
 
 tcMcStmt :: TcExprStmtChecker
 
-tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
+tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
   = do  { (body', return_op')
             <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
                \ [a_ty] ->
                tcMonoExprNC body (mkCheckExpType a_ty)
         ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
-        ; return (LastStmt body' noret return_op', thing) }
+        ; return (LastStmt x body' noret return_op', thing) }
 
 -- Generators for monad comprehensions ( pat <- rhs )
 --
@@ -566,7 +560,7 @@ tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
 --                            q   ::   a
 --
 
-tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
+tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
   = do  { ((rhs', pat', thing, new_res_ty), bind_op')
             <- tcSyntaxOp MCompOrigin bind_op
@@ -581,13 +575,13 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
 
-        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
 
 -- Boolean expressions.
 --
 --   [ body | stmts, expr ]  ->  expr :: m Bool
 --
-tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
+tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
   = do  { -- Deal with rebindable syntax:
           --    guard_op :: test_ty -> rhs_ty
           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
@@ -602,7 +596,7 @@ tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
                          tcMonoExpr rhs (mkCheckExpType test_ty)
                   ; thing <- thing_inside (mkCheckExpType new_res_ty)
                   ; return (thing, rhs', rhs_ty, guard_op') }
-        ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) }
+        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
 
 -- Grouping statements
 --
@@ -717,7 +711,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
        ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
                            , trS_by = by', trS_using = final_using
                            , trS_ret = return_op', trS_bind = bind_op'
-                           , trS_bind_arg_ty = n_app tup_ty
+                           , trS_ext = n_app tup_ty
                            , trS_fmap = fmap_op', trS_form = form }, thing) }
 
 -- A parallel set of comprehensions
@@ -749,7 +743,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
 --        -> m (st1, (st2, st3))
 --
-tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
+tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
   = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
        ; m_ty   <- newFlexiTyVarTy star_star_kind
 
@@ -763,7 +757,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
 
         -- type dummies since we don't know all binder types yet
        ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
-                       [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
+                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
 
        -- Typecheck bind:
        ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
@@ -778,7 +772,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
                                  tup_tys bndr_stmts_s
                  ; return (stuff, inner_res_ty) }
 
-       ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) }
+       ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
 
   where
     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
@@ -793,7 +787,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
                                    -- matching in the branches
 
     loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
-                           (ParStmtBlock stmts names return_op : pairs)
+                           (ParStmtBlock x stmts names return_op : pairs)
       = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
            ; (stmts', (ids, return_op', pairs', thing))
                 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
@@ -806,7 +800,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
                                      \ _ -> return ()
                       ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
                       ; return (ids, return_op', pairs', thing) }
-           ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
+           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
     loop _ _ _ _ = panic "tcMcStmt.loop"
 
 tcMcStmt _ stmt _ _
@@ -820,12 +814,12 @@ tcMcStmt _ stmt _ _
 
 tcDoStmt :: TcExprStmtChecker
 
-tcDoStmt _ (LastStmt body noret _) res_ty thing_inside
+tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
   = do { body' <- tcMonoExprNC body res_ty
        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
-       ; return (LastStmt body' noret noSyntaxExpr, thing) }
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
 
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
+tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax:
                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
                 -- This level of generality is needed for using do-notation
@@ -843,9 +837,9 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
 
-        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
 
-tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
+tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
   = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
                                 thing_inside . mkCheckExpType
         ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
@@ -855,9 +849,9 @@ tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
               (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
                \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
 
-        ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }
+        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
 
-tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
+tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax;
                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
         ; ((rhs', rhs_ty, thing), then_op')
@@ -866,7 +860,7 @@ tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
                   ; thing <- thing_inside (mkCheckExpType new_res_ty)
                   ; return (rhs', rhs_ty, thing) }
-        ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
+        ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
 
 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
@@ -912,9 +906,11 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
-                          , recS_bind_ty = new_res_ty
-                          , recS_later_rets = [], recS_rec_rets = tup_rets
-                          , recS_ret_ty = stmts_ty }, thing)
+                          , recS_ext = RecStmtTc
+                            { recS_bind_ty = new_res_ty
+                            , recS_later_rets = []
+                            , recS_rec_rets = tup_rets
+                            , recS_ret_ty = stmts_ty} }, thing)
         }}
 
 tcDoStmt _ stmt _ _
@@ -990,7 +986,7 @@ When typechecking
 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 pushing info from the context into the RHS.  To do this, we check the
 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
-Otherwise the error shows up when cheking the rebindable syntax, and
+Otherwise the error shows up when checking the rebindable syntax, and
 the expected/inferred stuff is back to front (see Trac #3613).
 
 Note [typechecking ApplicativeStmt]
@@ -1013,10 +1009,10 @@ join :: tn -> res_ty
 
 tcApplicativeStmts
   :: HsStmtContext Name
-  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)]
+  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
   -> ExpRhoType                         -- rhs_ty
   -> (TcRhoType -> TcM t)               -- thing_inside
-  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t)
+  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
 
 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
  = do { body_ty <- newFlexiTyVarTy liftedTypeKind
@@ -1054,18 +1050,18 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
            ; ops' <- goOps t_i ops
            ; return (op' : ops') }
 
-    goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type)
-          -> TcM (ApplicativeArg GhcTcId GhcTcId)
+    goArg :: (ApplicativeArg GhcRn, Type, Type)
+          -> TcM (ApplicativeArg GhcTcId)
 
-    goArg (ApplicativeArgOne pat rhs, pat_ty, exp_ty)
+    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)
       = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
         addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
         do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
            ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                           return ()
-           ; return (ApplicativeArgOne pat' rhs') }
+           ; return (ApplicativeArgOne x pat' rhs' isBody) }
 
-    goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty)
+    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
       = do { (stmts', (ret',pat')) <-
                 tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
                 \res_ty  -> do
@@ -1074,11 +1070,14 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
                                  return ()
                   ; return (ret', pat')
                   }
-           ; return (ApplicativeArgMany stmts' ret' pat') }
+           ; return (ApplicativeArgMany x stmts' ret' pat') }
+
+    goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"
 
-    get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id]
-    get_arg_bndrs (ApplicativeArgOne pat _)    = collectPatBinders pat
-    get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat
+    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
+    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+    get_arg_bndrs (XApplicativeArg _)            = panic "tcApplicativeStmts"
 
 
 {- Note [ApplicativeDo and constraints]
@@ -1134,4 +1133,6 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) })
     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 
     args_in_match :: LMatch GhcRn body -> Int
-    args_in_match (L _ (Match _ pats _ _)) = length pats
+    args_in_match (L _ (Match { m_pats = pats })) = length pats
+    args_in_match (L _ (XMatch _)) = panic "checkArgs"
+checkArgs _ (XMatchGroup{}) = panic "checkArgs"
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 0d0e16a346..ed797d389c 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -16,6 +16,8 @@ module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )
 
 import HsSyn
@@ -322,21 +324,21 @@ tc_pat  :: PatEnv
         -> TcM (Pat GhcTcId,    -- Translated pattern
                 a)              -- Result of thing inside
 
-tc_pat penv (VarPat (L l name)) pat_ty thing_inside
+tc_pat penv (VarPat x (L l name)) pat_ty thing_inside
   = do  { (wrap, id) <- tcPatBndr penv name pat_ty
         ; res <- tcExtendIdEnv1 name id thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) }
+        ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
 
-tc_pat penv (ParPat pat) pat_ty thing_inside
+tc_pat penv (ParPat x pat) pat_ty thing_inside
   = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
-        ; return (ParPat pat', res) }
+        ; return (ParPat x pat', res) }
 
-tc_pat penv (BangPat pat) pat_ty thing_inside
+tc_pat penv (BangPat x pat) pat_ty thing_inside
   = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
-        ; return (BangPat pat', res) }
+        ; return (BangPat x pat', res) }
 
-tc_pat penv (LazyPat pat) pat_ty thing_inside
+tc_pat penv (LazyPat x pat) pat_ty thing_inside
   = do  { (pat', (res, pat_ct))
                 <- tc_lpat pat pat_ty (makeLazy penv) $
                    captureConstraints thing_inside
@@ -348,16 +350,16 @@ tc_pat penv (LazyPat pat) pat_ty thing_inside
 
         -- Check that the expected pattern type is itself lifted
         ; pat_ty <- readExpType pat_ty
-        ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind
+        ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
 
-        ; return (LazyPat pat', res) }
+        ; return (LazyPat x pat', res) }
 
 tc_pat _ (WildPat _) pat_ty thing_inside
   = do  { res <- thing_inside
         ; pat_ty <- expTypeToType pat_ty
         ; return (WildPat pat_ty, res) }
 
-tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
+tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside
   = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
         ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
                          tc_lpat pat (mkCheckExpType $ idType bndr_id)
@@ -370,9 +372,10 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
             --
             -- If you fix it, don't forget the bindInstsOfPatIds!
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+        ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty,
+                  res) }
 
-tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
+tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
   = do  {
          -- Expr must have type `forall a1...aN. OPT' -> B`
          -- where overall_pat_ty is an instance of OPT'.
@@ -382,7 +385,7 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
         ; let expr_orig = lexprCtOrigin expr
               herald    = text "A view pattern expression expects"
         ; (expr_wrap1, [inf_arg_ty], inf_res_ty)
-            <- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred
+            <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred
             -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
 
          -- check that overall pattern is more polymorphic than arg type
@@ -399,30 +402,35 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
                --                (overall_pat_ty -> inf_res_ty)
               expr_wrap = expr_wrap2' <.> expr_wrap1
               doc = text "When checking the view pattern function:" <+> (ppr expr)
-        ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) }
+        ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
 
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
-tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
+tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside
   = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
                                                             sig_ty pat_ty
-        ; (pat', res) <- tcExtendTyVarEnv2 wcs      $
-                         tcExtendTyVarEnv2 tv_binds $
+                -- Using tcExtendNameTyVarEnv is appropriate here (not scopeTyVars2)
+                -- because we're not really bringing fresh tyvars into scope.
+                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+                -- from an outer scope to mention one of these tyvars in its kind.
+        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
+                         tcExtendNameTyVarEnv tv_binds $
                          tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
+        ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) }
 
 ------------------------
 -- Lists, tuples, arrays
-tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
+tc_pat penv (ListPat Nothing pats) pat_ty thing_inside
   = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
         ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                      pats penv thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res)
-        }
+        ; return (mkHsWrapPat coi
+                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
+}
 
-tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
+tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
   = do  { tau_pat_ty <- expTypeToType pat_ty
         ; ((pats', res, elt_ty), e')
             <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
@@ -431,18 +439,10 @@ tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
                  do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                                  pats penv thing_inside
                     ; return (pats', res, elt_ty) }
-        ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res)
-        }
-
-tc_pat penv (PArrPat pats _) pat_ty thing_inside
-  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty
-        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
-                                     pats penv thing_inside
-        ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)
-        }
+        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
+}
 
-tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
+tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
   = do  { let arity = length pats
               tc = tupleTyCon boxity arity
         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
@@ -461,19 +461,19 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
         -- This is a pretty odd place to make the switch, but
         -- it was easy to do.
         ; let
-              unmangled_result = TuplePat pats' boxity con_arg_tys
+              unmangled_result = TuplePat con_arg_tys pats' boxity
                                  -- pat_ty /= pat_ty iff coi /= IdCo
               possibly_mangled_result
                 | gopt Opt_IrrefutableTuples dflags &&
-                  isBoxed boxity            = LazyPat (noLoc unmangled_result)
-                | otherwise                 = unmangled_result
+                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)
+                | otherwise           = unmangled_result
 
         ; pat_ty <- readExpType pat_ty
         ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
           return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
         }
 
-tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside
+tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
   = do  { let tc = sumTyCon arity
         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
                                                penv pat_ty
@@ -482,7 +482,8 @@ tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside
         ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
                                  penv thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res)
+        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+                 , res)
         }
 
 ------------------------
@@ -492,12 +493,12 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
 
 ------------------------
 -- Literal patterns
-tc_pat penv (LitPat simple_lit) pat_ty thing_inside
+tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
   = do  { let lit_ty = hsLitType simple_lit
         ; wrap   <- tcSubTypePat penv pat_ty lit_ty
         ; res    <- thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty
+        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
                  , res) }
 
 ------------------------
@@ -518,7 +519,7 @@ tc_pat penv (LitPat simple_lit) pat_ty thing_inside
 -- where lit_ty is the type of the overloaded literal 5.
 --
 -- When there is no negation, neg_lit_ty and lit_ty are the same
-tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside
+tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside
   = do  { let orig = LiteralOrigin over_lit
         ; ((lit', mb_neg'), eq')
             <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
@@ -536,7 +537,7 @@ tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside
 
         ; res <- thing_inside
         ; pat_ty <- readExpType pat_ty
-        ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) }
+        ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
 
 {-
 Note [NPlusK patterns]
@@ -567,7 +568,8 @@ AST is used for the subtraction operation.
 -}
 
 -- See Note [NPlusK patterns]
-tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside
+tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty
+              thing_inside
   = do  { pat_ty <- expTypeToType pat_ty
         ; let orig = LiteralOrigin lit
         ; (lit1', ge')
@@ -596,15 +598,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in
 
         ; let minus'' = minus' { syn_res_wrap =
                                     minus_wrap <.> syn_res_wrap minus' }
-              pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2'
-                               ge' minus'' pat_ty
+              pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
+                               ge' minus''
         ; return (pat', res) }
 
 -- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
 -- Here we get rid of it and add the finalizers to the global environment.
 --
 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
-tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat)))
+tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
             pat_ty thing_inside
   = do addModFinalizersWithLclEnv mod_finalizers
        tc_pat penv pat pat_ty thing_inside
@@ -736,8 +738,13 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
 
         ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys
         ; checkExistentials ex_tvs all_arg_tys penv
-        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX
-                               (zipTvSubst univ_tvs ctxt_res_tys) ex_tvs
+
+        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys
+                  -- NB: Do not use zipTvSubst!  See Trac #14154
+                  -- We want to create a well-kinded substitution, so
+                  -- that the instantiated type is well-kinded
+
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
                      -- Get location from monad, not from ex_tvs
 
         ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
@@ -896,7 +903,7 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
                                              ppr exp_pat_ty,
                                              ppr pat_ty,
                                              ppr pat_rho, ppr wrap])
-       ; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
+       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
              -- co1 : T (ty1,ty2) ~N pat_rho
              -- could use tcSubType here... but it's the wrong way round
              -- for actual vs. expected in error messages.
@@ -975,17 +982,20 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
   where
     tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
                         (LHsRecField GhcTcId (LPat GhcTcId))
-    tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv
+    tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv
                                                                     thing_inside
       = do { sel'   <- tcLookupId sel
-           ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr)
+           ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+                                          (occNameFS $ rdrNameOcc rdr)
            ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
-           ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat'
+           ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'
                                                                     pun), res) }
+    tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _
+           = panic "tcConArgs"
 
-    find_field_ty :: FieldLabelString -> TcM TcType
-    find_field_ty lbl
-        = case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of
+    find_field_ty :: Name -> FieldLabelString -> TcM TcType
+    find_field_ty sel lbl
+        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of
 
                 -- No matching field; chances are this field label comes from some
                 -- other record type (or maybe none).  If this happens, just fail,
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 8f99a23b08..d10829f075 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -9,20 +9,21 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
-                , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
+module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
+                , tcPatSynBuilderOcc, nonBidirectionalErr
   ) where
 
+import GhcPrelude
+
 import HsSyn
 import TcPat
-import Type( mkTyVarBinders, mkEmptyTCvSubst
-           , tidyTyVarBinders, tidyTypes, tidyType )
+import Type( mkEmptyTCvSubst, tidyTyCoVarBinders, tidyTypes, tidyType )
 import TcRnMonad
 import TcSigs( emptyPragEnv, completeSigFromId )
+import TcType( mkMinimalBySCs )
 import TcEnv
 import TcMType
-import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes
-              , zonkTcTypeToType, emptyZonkEnv )
+import TcHsSyn
 import TysPrim
 import TysWiredIn  ( runtimeRepTy )
 import Name
@@ -51,7 +52,7 @@ import FieldLabel
 import Bag
 import Util
 import ErrUtils
-import Control.Monad ( zipWithM )
+import Control.Monad ( zipWithM, when )
 import Data.List( partition )
 
 #include "HsVersions.h"
@@ -64,41 +65,230 @@ import Data.List( partition )
 ************************************************************************
 -}
 
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcPatSynDecl psb@(PSB { psb_id = L _ name, psb_args = details }) mb_sig
+  = recoverM recover $
+    case mb_sig of
+      Nothing                 -> tcInferPatSynDecl psb
+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
+      _ -> panic "tcPatSynDecl"
+
+  where
+    -- See Note [Pattern synonym error recovery]
+    recover = do { matcher_name <- newImplicitBinder name mkMatcherOcc
+                 ; let placeholder = AConLike $ PatSynCon $
+                                     mk_placeholder matcher_name
+                 ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
+                 ; return (emptyBag, gbl_env) }
+
+    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
+    mk_placeholder matcher_name
+      = mkPatSyn name is_infix
+                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
+                        [] -- Arg tys
+                        alphaTy
+                        (matcher_id, True) Nothing
+                        []  -- Field labels
+       where
+         -- The matcher_id is used only by the desugarer, so actually
+         -- and error-thunk would probably do just as well here.
+         matcher_id = mkLocalId matcher_name $
+                      mkSpecForAllTys [alphaTyVar] alphaTy
+
+tcPatSynDecl (XPatSynBind {}) _ = panic "tcPatSynDecl"
+
+{- Note [Pattern synonym error recovery]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If type inference for a pattern synonym fails , we can't continue with
+the rest of tc_patsyn_finish, because we may get knock-on errors, or
+even a crash.  E.g. from
+   pattern What = True :: Maybe
+we get a kind error; and we must stop right away (Trac #15289).
+Hence the 'when insoluble failM' in tcInferPatSyn.
+
+But does that abort compilation entirely?  No -- we can recover
+and carry on, just as we do for value bindings, provided we plug in
+placeholder for the pattern synonym.  The goal of the placeholder
+is not to cause a raft of follow-on errors.  I've used the simplest
+thing for now, but we might need to elaborate it a bit later.  (e.g.
+I've given it zero args, which may cause knock-on errors if it is
+used in a pattern.) But it'll do for now.
+-}
+
 tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
                   -> TcM (LHsBinds GhcTc, TcGblEnv)
 tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                        psb_def = lpat, psb_dir = dir }
   = addPatSynCtxt lname $
     do { traceTc "tcInferPatSynDecl {" $ ppr name
-       ; tcCheckPatSynPat lpat
 
        ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
        ; (tclvl, wanted, ((lpat', args), pat_ty))
             <- pushLevelAndCaptureConstraints  $
-               tcInferNoInst $ \ exp_ty ->
-               tcPat PatSyn lpat exp_ty $
+               tcInferNoInst                   $ \ exp_ty ->
+               tcPat PatSyn lpat exp_ty        $
                mapM tcLookupId arg_names
 
        ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
 
-       ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions []
-                                                      named_taus wanted
+       ; (qtvs, req_dicts, ev_binds, insoluble)
+               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
+
+       ; when insoluble failM
+              -- simplifyInfer doesn't fail if there are errors.  But to avoid
+              -- knock-on errors, or even crashes, we want to stop here.
+              -- See Note [Pattern synonym error recovery]
 
        ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
              ex_tv_set  = mkVarSet ex_tvs
              univ_tvs   = filterOut (`elemVarSet` ex_tv_set) qtvs
-             prov_theta = map evVarPred prov_dicts
              req_theta  = map evVarPred req_dicts
 
+       ; prov_dicts <- mapM zonkId prov_dicts
+       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
+             prov_theta = map evVarPred filtered_prov_dicts
+             -- Filtering: see Note [Remove redundant provided dicts]
+
+       -- Report bad universal type variables
+       -- See Note [Type variables whose kind is captured]
+       ; let bad_tvs    = [ tv | tv <- univ_tvs
+                               , tyCoVarsOfType (tyVarKind tv)
+                                 `intersectsVarSet` ex_tv_set ]
+       ; mapM_ (badUnivTvErr ex_tvs) bad_tvs
+
+       -- Report coercions that esacpe
+       -- See Note [Coercions that escape]
+       ; args <- mapM zonkId args
+       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
+                              , let bad_cos = filterDVarSet isId $
+                                              (tyCoVarsOfTypeDSet (idType arg))
+                              , not (isEmptyDVarSet bad_cos) ]
+       ; mapM_ dependentArgErr bad_args
+
        ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (mkTyVarBinders Inferred univ_tvs
                             , req_theta,  ev_binds, req_dicts)
                           (mkTyVarBinders Inferred ex_tvs
-                            , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts)
+                            , mkTyVarTys ex_tvs, prov_theta
+                            , map (EvExpr . evId) filtered_prov_dicts)
                           (map nlHsVar args, map idType args)
                           pat_ty rec_fields }
-
+tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
+
+badUnivTvErr :: [TyVar] -> TyVar -> TcM ()
+-- See Note [Type variables whose kind is captured]
+badUnivTvErr ex_tvs bad_tv
+  = addErrTc $
+    vcat [ text "Universal type variable" <+> quotes (ppr bad_tv)
+                <+> text "has existentially bound kind:"
+         , nest 2 (ppr_with_kind bad_tv)
+         , hang (text "Existentially-bound variables:")
+              2 (vcat (map ppr_with_kind ex_tvs))
+         , text "Probable fix: give the pattern synonym a type signature"
+         ]
+  where
+    ppr_with_kind tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+
+dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+-- See Note [Coercions that escape]
+dependentArgErr (arg, bad_cos)
+  = addErrTc $
+    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
+         , hang (text "Pattern-bound variable")
+              2 (ppr arg <+> dcolon <+> ppr (idType arg))
+         , nest 2 $
+           hang (text "has a type that mentions pattern-bound coercion"
+                 <> plural bad_co_list <> colon)
+              2 (pprWithCommas ppr bad_co_list)
+         , text "Hint: use -fprint-explicit-coercions to see the coercions"
+         , text "Probable fix: add a pattern signature" ]
+  where
+    bad_co_list = dVarSetElems bad_cos
+
+{- Note [Remove redundant provided dicts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that
+   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
+                                       => a1 :~~: a2
+(NB: technically the (k1~k2) existential dictionary is not necessary,
+but it's there at the moment.)
+
+Now consider (Trac #14394):
+   pattern Foo = HRefl
+in a non-poly-kinded module.  We don't want to get
+    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
+with that redundant (* ~ *).  We'd like to remove it; hence the call to
+mkMinimalWithSCs.
+
+Similarly consider
+  data S a where { MkS :: Ord a => a -> S a }
+  pattern Bam x y <- (MkS (x::a), MkS (y::a)))
+
+The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
+need one.  Agian mkMimimalWithSCs removes the redundant one.
+
+Note [Type variables whose kind is captured]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data AST a = Sym [a]
+  class Prj s where { prj :: [a] -> Maybe (s a)
+  pattern P x <= Sym (prj -> Just x)
+
+Here we get a matcher with this type
+  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
+
+No problem.  But note that 's' is not fixed by the type of the
+pattern (AST a), nor is it existentially bound.  It's really only
+fixed by the type of the continuation.
+
+Trac #14552 showed that this can go wrong if the kind of 's' mentions
+existentially bound variables.  We obviously can't make a type like
+  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
+                                   -> r -> r
+But neither is 's' itself existentially bound, so the forall (s::k->*)
+can't go in the inner forall either.  (What would the matcher apply
+the continuation to?)
+
+So we just fail in this case, with a pretty terrible error message.
+Maybe we could do better, but I can't see how.  (It'd be possible to
+default 's' to (Any k), but that probably isn't what the user wanted,
+and it not straightforward to implement, because by the time we see
+the problem, simplifyInfer has already skolemised 's'.)
+
+This stuff can only happen in the presence of view patterns, with
+PolyKinds, so it's a bit of a corner case.
+
+Note [Coercions that escape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #14507 showed an example where the inferred type of the matcher
+for the pattern synonym was somethign like
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
+selection) by the pattern being matched; and indeed it is implicit in
+the context (Bool ~ k).  You could imagine trying to extract it like
+this:
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
+                  let co_a2sv = sc_sel co
+                  in TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+But we simply don't allow that in types.  Maybe one day but not now.
+
+How to detect this situation?  We just look for free coercion variables
+in the types of any of the arguments to the matcher.  The error message
+is not very helpful, but at least we don't get a Lint error.
+-}
 
 tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
                   -> TcPatSynInfo
@@ -117,8 +307,6 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
          vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
               , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
 
-       ; tcCheckPatSynPat lpat
-
        ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
                                  Right stuff  -> return stuff
                                  Left missing -> wrongNumberOfParmsErr name decl_arity missing
@@ -133,7 +321,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
             2 (text "mentions existential type variable" <> plural bad_tvs
                <+> pprQuotedList bad_tvs)
 
-         -- See Note [The pattern-synonym signature splitting rule]
+         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
        ; let univ_fvs = closeOverKinds $
                         (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
              (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
@@ -149,6 +337,9 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
            ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
            pushLevelAndCaptureConstraints            $
            tcExtendTyVarEnv univ_tvs                 $
+           tcExtendKindEnvList [(getName (binderVar ex_tv), APromotionErr PatSynExPE)
+                               | ex_tv <- extra_ex] $
+               -- See Note [Pattern synonym existentials do not scope]
            tcPat PatSyn lpat (mkCheckExpType pat_ty) $
            do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
                     empty_subst = mkEmptyTCvSubst in_scope
@@ -199,6 +390,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                 -- Why do we need tcSubType here?
                 -- See Note [Pattern synonyms and higher rank types]
            ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
+tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
 
 {- [Pattern synonyms and higher rank types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -212,6 +404,98 @@ This should work.  But in the matcher we must match against MkT, and then
 instantiate its argument 'x', to get a function of type (Int -> Int).
 Equality is not enough!  Trac #13752 was an example.
 
+Note [Pattern synonym existentials do not scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #14498):
+  pattern SS :: forall (t :: k). () =>
+                => forall (a :: kk -> k) (n :: kk).
+                => TypeRep n -> TypeRep t
+  pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)
+
+Here 'k' is implicitly bound in the signature, but (with
+-XScopedTypeVariables) it does still scope over the pattern-synonym
+definition.  But what about 'kk', which is oexistential?  It too is
+implicitly bound in the signature; should it too scope?  And if so,
+what type variable is it bound to?
+
+The trouble is that the type variable to which it is bound is itself
+only brought into scope in part the pattern, so it makes no sense for
+'kk' to scope over the whole pattern.  See the discussion on
+Trac #14498, esp comment:16ff. Here is a simpler example:
+  data T where { MkT :: x -> (x->Int) -> T }
+  pattern P :: () => forall x. x -> (x->Int) -> T
+  pattern P a b = (MkT a b, True)
+
+Here it would make no sense to mention 'x' in the True pattern,
+like this:
+  pattern P a b = (MkT a b, True :: x)
+
+The 'x' only makes sense "under" the MkT pattern. Conclusion: the
+existential type variables of a pattern-synonym signature should not
+scope.
+
+But it's not that easy to implement, because we don't know
+exactly what the existentials /are/ until we get to type checking.
+(See Note [The pattern-synonym signature splitting rule], and
+the partition of implicit_tvs in tcCheckPatSynDecl.)
+
+So we do this:
+
+- The reaner brings all the implicitly-bound kind variables into
+  scope, without trying to distinguish universal from existential
+
+- tcCheckPatSynDecl uses tcExtendKindEnvList to bind the
+  implicitly-bound existentials to
+      APromotionErr PatSynExPE
+  It's not really a promotion error, but it's a way to bind the Name
+  (which the renamer has not complained about) to something that, when
+  looked up, will cause a complaint (in this case
+  TcHsType.promotionErr)
+
+
+Note [The pattern-synonym signature splitting rule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a pattern signature, we must split
+     the kind-generalised variables, and
+     the implicitly-bound variables
+into universal and existential.  The rule is this
+(see discussion on Trac #11224):
+
+     The universal tyvars are the ones mentioned in
+          - univ_tvs: the user-specified (forall'd) universals
+          - req_theta
+          - res_ty
+     The existential tyvars are all the rest
+
+For example
+
+   pattern P :: () => b -> T a
+   pattern P x = ...
+
+Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
+how do we split the arg_tys from req_ty?  Consider
+
+   pattern Q :: () => b -> S c -> T a
+   pattern Q x = ...
+
+This is an odd example because Q has only one syntactic argument, and
+so presumably is defined by a view pattern matching a function.  But
+it can happen (Trac #11977, #12108).
+
+We don't know Q's arity from the pattern signature, so we have to wait
+until we see the pattern declaration itself before deciding res_ty is,
+and hence which variables are existential and which are universal.
+
+And that in turn is why TcPatSynInfo has a separate field,
+patsig_implicit_bndrs, to capture the implicitly bound type variables,
+because we don't yet know how to split them up.
+
+It's a slight compromise, because it means we don't really know the
+pattern synonym's real signature until we see its declaration.  So,
+for example, in hs-boot file, we may need to think what to do...
+(eg don't have any implicitly-bound variables).
+
+
 Note [Checking against a pattern signature]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When checking the actual supplied pattern against the pattern synonym
@@ -265,10 +549,10 @@ a pattern synonym.  What about the /building/ side?
   tcPatSynBuilderBind, by converting the pattern to an expression and
   typechecking it.
 
-  At one point, for ImplicitBidirectional I used SigTvs (instead of
+  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
   TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
   is redundant since tcPatSynBuilderBind does the job, (b) it was
-  still incomplete (SigTvs can unify with each other), and (c) it
+  still incomplete (TyVarTvs can unify with each other), and (c) it
   didn't even work (Trac #13441 was accepted with
   ExplicitBidirectional, but rejected if expressed in
   ImplicitBidirectional form.  Conclusion: trying to be too clever is
@@ -279,12 +563,11 @@ collectPatSynArgInfo :: HsPatSynDetails (Located Name)
                      -> ([Name], [Name], Bool)
 collectPatSynArgInfo details =
   case details of
-    PrefixPatSyn names      -> (map unLoc names, [], False)
-    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
-    RecordPatSyn names ->
-      let (vars, sels) = unzip (map splitRecordPatSyn names)
-      in (vars, sels, False)
-
+    PrefixCon names      -> (map unLoc names, [], False)
+    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
+    RecCon names         -> (vars, sels, False)
+                         where
+                            (vars, sels) = unzip (map splitRecordPatSyn names)
   where
     splitRecordPatSyn :: RecordPatSynField (Located Name)
                       -> (Name, Name)
@@ -328,15 +611,15 @@ tc_patsyn_finish lname dir is_infix lpat'
   = do { -- Zonk everything.  We are about to build a final PatSyn
          -- so there had better be no unification variables in there
 
-         (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs
-       ; req_theta'      <- zonkTcTypeToTypes ze req_theta
+         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
+       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
        ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
-       ; prov_theta'       <- zonkTcTypeToTypes ze prov_theta
-       ; pat_ty'         <- zonkTcTypeToType ze pat_ty
-       ; arg_tys'        <- zonkTcTypeToTypes ze arg_tys
+       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
+       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
+       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
 
-       ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs'
-             (env2, ex_tvs)   = tidyTyVarBinders env1 ex_tvs'
+       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
+             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
              req_theta  = tidyTypes env2 req_theta'
              prov_theta = tidyTypes env2 prov_theta'
              arg_tys    = tidyTypes env2 arg_tys'
@@ -410,9 +693,9 @@ tcPatSynMatcher (L loc name) lpat
                 (args, arg_tys) pat_ty
   = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
        ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
-       ; let rr_tv  = mkTcTyVar rr_name runtimeRepTy vanillaSkolemTv
+       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
              rr     = mkTyVarTy rr_tv
-             res_tv = mkTcTyVar tv_name (tYPE rr) vanillaSkolemTv
+             res_tv = mkTyVar tv_name (tYPE rr)
              res_ty = mkTyVarTy res_tv
              is_unlifted = null args && null prov_dicts
              (cont_args, cont_arg_tys)
@@ -434,7 +717,7 @@ tcPatSynMatcher (L loc name) lpat
                              -- See Note [Exported LocalIds] in Id
 
              inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
-             cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
+             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
 
              fail' = nlHsApps fail [nlHsVar voidPrimId]
 
@@ -446,35 +729,32 @@ tcPatSynMatcher (L loc name) lpat
                            mkHsCaseAlt lwpat fail']
              body = mkLHsWrap (mkWpLet req_ev_binds) $
                     L (getLoc lpat) $
-                    HsCase (nlHsVar scrutinee) $
+                    HsCase noExt (nlHsVar scrutinee) $
                     MG{ mg_alts = L (getLoc lpat) cases
-                      , mg_arg_tys = [pat_ty]
-                      , mg_res_ty = res_ty
+                      , mg_ext = MatchGroupTc [pat_ty] res_ty
                       , mg_origin = Generated
                       }
              body' = noLoc $
-                     HsLam $
+                     HsLam noExt $
                      MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
                                                         args body]
-                       , mg_arg_tys = [pat_ty, cont_ty, fail_ty]
-                       , mg_res_ty = res_ty
+                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
                        , mg_origin = Generated
                        }
              match = mkMatch (mkPrefixFunRhs (L loc name)) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
-                             req_dicts body')
-                             (noLoc EmptyLocalBinds)
+                                       req_dicts body')
+                             (noLoc (EmptyLocalBinds noExt))
              mg :: MatchGroup GhcTc (LHsExpr GhcTc)
              mg = MG{ mg_alts = L (getLoc match) [match]
-                    , mg_arg_tys = []
-                    , mg_res_ty = res_ty
+                    , mg_ext = MatchGroupTc [] res_ty
                     , mg_origin = Generated
                     }
 
-       ; let bind = FunBind{ fun_id = L loc matcher_id
+       ; let bind = FunBind{ fun_ext = emptyNameSet
+                           , fun_id = L loc matcher_id
                            , fun_matches = mg
                            , fun_co_fn = idHsWrapper
-                           , bind_fvs = emptyNameSet
                            , fun_tick = [] }
              matcher_bind = unitBag (noLoc bind)
 
@@ -485,12 +765,10 @@ tcPatSynMatcher (L loc name) lpat
 
 mkPatSynRecSelBinds :: PatSyn
                     -> [FieldLabel]  -- ^ Visible field labels
-                    -> HsValBinds GhcRn
+                    -> [(Id, LHsBind GhcRn)]
 mkPatSynRecSelBinds ps fields
-  = ValBindsOut selector_binds sigs
-  where
-    (sigs, selector_binds) = unzip (map mkRecSel fields)
-    mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+    | fld_lbl <- fields ]
 
 isUnidirectional :: HsPatSynDir a -> Bool
 isUnidirectional Unidirectional          = True
@@ -550,16 +828,21 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
 
   | Right match_group <- mb_match_group  -- Bidirectional
   = do { patsyn <- tcLookupPatSyn name
-       ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
-                   -- Bidirectional, so patSynBuilder returns Just
-
-             match_group' | need_dummy_arg = add_dummy_arg match_group
+       ; case patSynBuilder patsyn of {
+           Nothing -> return emptyBag ;
+             -- This case happens if we found a type error in the
+             -- pattern synonym, recovered, and put a placeholder
+             -- with patSynBuilder=Nothing in the environment
+
+           Just (builder_id, need_dummy_arg) ->  -- Normal case
+    do { -- Bidirectional, so patSynBuilder returns Just
+         let match_group' | need_dummy_arg = add_dummy_arg match_group
                           | otherwise      = match_group
 
-             bind = FunBind { fun_id      = L loc (idName builder_id)
+             bind = FunBind { fun_ext = placeHolderNamesTc
+                            , fun_id      = L loc (idName builder_id)
                             , fun_matches = match_group'
                             , fun_co_fn   = idHsWrapper
-                            , bind_fvs    = placeHolderNamesTc
                             , fun_tick    = [] }
 
              sig = completeSigFromId (PatSynCtxt name) builder_id
@@ -568,28 +851,28 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
          ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
        ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
-       ; return builder_binds }
+       ; return builder_binds } } }
 
   | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
   where
     mb_match_group
        = case dir of
            ExplicitBidirectional explicit_mg -> Right explicit_mg
-           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
            Unidirectional -> panic "tcPatSynBuilderBind"
 
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
     mk_mg body = mkMatchGroup Generated [builder_match]
-             where
-               builder_args  = [L loc (VarPat (L loc n)) | L loc n <- args]
-               builder_match = mkMatch (mkPrefixFunRhs (L loc name))
-                                       builder_args body
-                                       (noLoc EmptyLocalBinds)
+          where
+            builder_args  = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
+            builder_match = mkMatch (mkPrefixFunRhs (L loc name))
+                                    builder_args body
+                                    (noLoc (EmptyLocalBinds noExt))
 
     args = case details of
-              PrefixPatSyn args     -> args
-              InfixPatSyn arg1 arg2 -> [arg1, arg2]
-              RecordPatSyn args     -> map recordPatSynPatVar args
+              PrefixCon args     -> args
+              InfixCon arg1 arg2 -> [arg1, arg2]
+              RecCon args        -> map recordPatSynPatVar args
 
     add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                   -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -597,12 +880,13 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
       = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
     add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
                              pprMatches other_mg
+tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
 
 tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
 -- monadic only for failure
 tcPatSynBuilderOcc ps
   | Just (builder_id, add_void_arg) <- builder
-  , let builder_expr = HsConLikeOut (PatSynCon ps)
+  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
         builder_ty   = idType builder_id
   = return $
     if add_void_arg
@@ -622,7 +906,8 @@ add_void need_dummy_arg ty
   | need_dummy_arg = mkFunTy voidPrimTy ty
   | otherwise      = ty
 
-tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
+tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
+            -> Either MsgDoc (LHsExpr GhcRn)
 -- Given a /pattern/, return an /expression/ that builds a value
 -- that matches the pattern.  E.g. if the pattern is (Just [x]),
 -- the expression is (Just [x]).  They look the same, but the
@@ -631,7 +916,7 @@ tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
 --
 -- Returns (Left r) if the pattern is not invertible, for reason r.
 -- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr args pat = go pat
+tcPatToExpr name args pat = go pat
   where
     lhsVars = mkNameSet (map unLoc args)
 
@@ -640,14 +925,14 @@ tcPatToExpr args pat = go pat
                     -> Either MsgDoc (HsExpr GhcRn)
     mkPrefixConExpr lcon@(L loc _) pats
       = do { exprs <- mapM go pats
-           ; return (foldl (\x y -> HsApp (L loc x) y)
-                           (HsVar lcon) exprs) }
+           ; return (foldl' (\x y -> HsApp noExt (L loc x) y)
+                            (HsVar noExt lcon) exprs) }
 
     mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
                     -> Either MsgDoc (HsExpr GhcRn)
     mkRecordConExpr con fields
       = do { exprFields <- mapM go fields
-           ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) }
+           ; return (RecordCon noExt con exprFields) }
 
     go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
     go (L loc p) = L loc <$> go1 p
@@ -659,44 +944,78 @@ tcPatToExpr args pat = go pat
           InfixCon l r  -> mkPrefixConExpr con [l,r]
           RecCon fields -> mkRecordConExpr con fields
 
-    go1 (SigPatIn pat _) = go1 (unLoc pat)
+    go1 (SigPat _ pat) = go1 (unLoc pat)
         -- See Note [Type signatures and the builder expression]
 
-    go1 (VarPat (L l var))
+    go1 (VarPat _ (L l var))
         | var `elemNameSet` lhsVars
-        = return $ HsVar (L l var)
+        = return $ HsVar noExt (L l var)
         | otherwise
         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
-    go1 (ParPat pat)                = fmap HsPar $ go pat
-    go1 (LazyPat pat)               = go1 (unLoc pat)
-    go1 (BangPat pat)               = go1 (unLoc pat)
-    go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
-                                         ; return $ ExplicitPArr ptt exprs }
-    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
-                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }
-    go1 (TuplePat pats box _)       = do { exprs <- mapM go pats
-                                         ; return $ ExplicitTuple
-                                              (map (noLoc . Present) exprs) box }
-    go1 (SumPat pat alt arity _)    = do { expr <- go1 (unLoc pat)
-                                         ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder
+    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat
+    go1 p@(ListPat reb pats)
+      | Nothing <- reb = do { exprs <- mapM go pats
+                            ; return $ ExplicitList noExt Nothing exprs }
+      | otherwise                   = notInvertibleListPat p
+    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
+                                         ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) exprs)
+                                                                           box }
+    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
+                                         ; return $ ExplicitSum noExt alt arity
+                                                                   (noLoc expr)
                                          }
-    go1 (LitPat lit)                = return $ HsLit lit
-    go1 (NPat (L _ n) mb_neg _ _)
-        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)]
-        | otherwise                 = return $ HsOverLit n
+    go1 (LitPat _ lit)              = return $ HsLit noExt lit
+    go1 (NPat _ (L _ n) mb_neg _)
+        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg
+                                                     [noLoc (HsOverLit noExt n)]
+        | otherwise                 = return $ HsOverLit noExt n
     go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
-    go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"
     go1 (CoPat{})                   = panic "CoPat in output of renamer"
-    go1 (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                     = go1 pat
-    go1 (SplicePat (HsSpliced{}))   = panic "Invalid splice variety"
-    go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")
+    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
+
+    -- The following patterns are not invertible.
+    go1 p@(BangPat {})                       = notInvertible p -- #14112
+    go1 p@(LazyPat {})                       = notInvertible p
+    go1 p@(WildPat {})                       = notInvertible p
+    go1 p@(AsPat {})                         = notInvertible p
+    go1 p@(ViewPat {})                       = notInvertible p
+    go1 p@(NPlusKPat {})                     = notInvertible p
+    go1 p@(XPat {})                          = notInvertible p
+    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
+    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
+    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
+    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p
+
+    notInvertible p = Left (not_invertible_msg p)
+
+    not_invertible_msg p
+      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+                <+> text "pattern synonym, e.g.")
+             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+                      <+> ppr pat <+> text "where")
+                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
+      where
+        pp_name = ppr name
+        pp_args = hsep (map ppr args)
+
+    -- We should really be able to invert list patterns, even when
+    -- rebindable syntax is on, but doing so involves a bit of
+    -- refactoring; see Trac #14380.  Until then we reject with a
+    -- helpful error message.
+    notInvertibleListPat p
+      = Left (vcat [ not_invertible_msg p
+                   , text "Reason: rebindable syntax is on."
+                   , text "This is fixable: add use-case to Trac #14380" ])
 
 {- Note [Builder for a bidirectional pattern synonym]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For a bidirectional pattern synonym we need to produce an /expression/
 that matches the supplied /pattern/, given values for the arguments
-of the pattern synoymy.  For example
+of the pattern synonym.  For example
   pattern F x y = (Just x, [y])
 The 'builder' for F looks like
   $builderF x y = (Just x, [y])
@@ -772,49 +1091,6 @@ Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
 want to avoid difficult to decipher core lint errors!
  -}
 
-tcCheckPatSynPat :: LPat GhcRn -> TcM ()
-tcCheckPatSynPat = go
-  where
-    go :: LPat GhcRn -> TcM ()
-    go = addLocM go1
-
-    go1 :: Pat GhcRn -> TcM ()
-    go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
-    go1   VarPat{}            = return ()
-    go1   WildPat{}           = return ()
-    go1 p@(AsPat _ _)         = asPatInPatSynErr p
-    go1   (LazyPat pat)       = go pat
-    go1   (ParPat pat)        = go pat
-    go1   (BangPat pat)       = go pat
-    go1   (PArrPat pats _)    = mapM_ go pats
-    go1   (ListPat pats _ _)  = mapM_ go pats
-    go1   (TuplePat pats _ _) = mapM_ go pats
-    go1   (SumPat pat _ _ _)  = go pat
-    go1   LitPat{}            = return ()
-    go1   NPat{}              = return ()
-    go1   (SigPatIn pat _)    = go pat
-    go1   (ViewPat _ pat _)   = go pat
-    go1   (SplicePat splice)
-      | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice
-                              = do addModFinalizersWithLclEnv mod_finalizers
-                                   go1 pat
-      | otherwise             = panic "non-pattern from spliced thing"
-    go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
-    go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
-    go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
-    go1   CoPat{}             = panic "CoPat in output of renamer"
-
-asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a
-asPatInPatSynErr pat
-  = failWithTc $
-    hang (text "Pattern synonym definition cannot contain as-patterns (@):")
-       2 (ppr pat)
-
-nPlusKPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a
-nPlusKPatInPatSynErr pat
-  = failWithTc $
-    hang (text "Pattern synonym definition cannot contain n+k-pattern:")
-       2 (ppr pat)
 
 nonBidirectionalErr :: Outputable name => name -> TcM a
 nonBidirectionalErr name = failWithTc $
@@ -839,20 +1115,19 @@ tcCollectEx pat = go pat
     go = go1 . unLoc
 
     go1 :: Pat GhcTc -> ([TyVar], [EvVar])
-    go1 (LazyPat p)         = go p
-    go1 (AsPat _ p)         = go p
-    go1 (ParPat p)          = go p
-    go1 (BangPat p)         = go p
-    go1 (ListPat ps _ _)    = mergeMany . map go $ ps
-    go1 (TuplePat ps _ _)   = mergeMany . map go $ ps
-    go1 (SumPat p _ _ _)    = go p
-    go1 (PArrPat ps _)      = mergeMany . map go $ ps
-    go1 (ViewPat _ p _)     = go p
-    go1 con@ConPatOut{}     = merge (pat_tvs con, pat_dicts con) $
+    go1 (LazyPat _ p)      = go p
+    go1 (AsPat _ _ p)      = go p
+    go1 (ParPat _ p)       = go p
+    go1 (BangPat _ p)      = go p
+    go1 (ListPat _ ps)     = mergeMany . map go $ ps
+    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
+    go1 (SumPat _ p _ _)   = go p
+    go1 (ViewPat _ _ p)    = go p
+    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
                               goConDetails $ pat_args con
-    go1 (SigPatOut p _)     = go p
-    go1 (CoPat _ p _)       = go1 p
-    go1 (NPlusKPat n k _ geq subtract _)
+    go1 (SigPat _ p)       = go p
+    go1 (CoPat _ _ p _)    = go1 p
+    go1 (NPlusKPat _ n k _ geq subtract)
       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
     go1 _                   = empty
 
diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot
index 5db79fcbbb..3538682f69 100644
--- a/compiler/typecheck/TcPatSyn.hs-boot
+++ b/compiler/typecheck/TcPatSyn.hs-boot
@@ -1,17 +1,15 @@
 module TcPatSyn where
 
 import HsSyn     ( PatSynBind, LHsBinds )
-import TcRnTypes ( TcM, TcPatSynInfo )
+import TcRnTypes ( TcM, TcSigInfo )
 import TcRnMonad ( TcGblEnv)
 import Outputable ( Outputable )
 import HsExtension ( GhcRn, GhcTc )
+import Data.Maybe  ( Maybe )
 
-tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-                  -> TcM (LHsBinds GhcTc, TcGblEnv)
-
-tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-                  -> TcPatSynInfo
-                  -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
 
 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
 
diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs
index b195a555f9..a112003ef9 100644
--- a/compiler/typecheck/TcPluginM.hs
+++ b/compiler/typecheck/TcPluginM.hs
@@ -53,6 +53,8 @@ module TcPluginM (
     ) where
 
 #if defined(GHCI)
+import GhcPrelude
+
 import qualified TcRnMonad as TcM
 import qualified TcSMonad  as TcS
 import qualified TcEnv     as TcM
@@ -67,8 +69,8 @@ import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
                   , liftIO, traceTc )
 import TcMType    ( TcTyVar, TcType )
 import TcEnv      ( TcTyThing )
-import TcEvidence ( TcCoercion, CoercionHole
-                  , EvTerm, EvBind, mkGivenEvBind )
+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
+                  , EvExpr, EvBind, mkGivenEvBind )
 import TcRnTypes  ( CtEvidence(..) )
 import Var        ( EvVar )
 
@@ -168,10 +170,10 @@ newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
 -- | Create a new given constraint, with the supplied evidence.  This
 -- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
 -- will panic.
-newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
+newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
 newGiven loc pty evtm = do
    new_ev <- newEvVar pty
-   setEvBind $ mkGivenEvBind new_ev evtm
+   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
    return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
 
 -- | Create a fresh evidence variable.
@@ -179,8 +181,8 @@ newEvVar :: PredType -> TcPluginM EvVar
 newEvVar = unsafeTcPluginTcM . TcM.newEvVar
 
 -- | Create a fresh coercion hole.
-newCoercionHole :: TcPluginM CoercionHole
-newCoercionHole = unsafeTcPluginTcM $ TcM.newCoercionHole
+newCoercionHole :: PredType -> TcPluginM CoercionHole
+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
 
 -- | Bind an evidence variable.  This must not be invoked from
 -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
@@ -188,4 +190,7 @@ setEvBind :: EvBind -> TcPluginM ()
 setEvBind ev_bind = do
     tc_evbinds <- getEvBindsTcPluginM
     unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
+#else
+-- this dummy import is needed as a consequence of NoImplicitPrelude
+import GhcPrelude ()
 #endif
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 8a6d72ee52..0648edd6cc 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2,17 +2,19 @@
 (c) The University of Glasgow 2006
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
-\section[TcMovectle]{Typechecking a whole module}
+\section[TcRnDriver]{Typechecking a whole module}
 
 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module TcRnDriver (
         tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
@@ -40,8 +42,11 @@ module TcRnDriver (
         badReexportedBootThing,
         checkBootDeclM,
         missingBootThing,
+        getRenamedStuff, RenamedStuff
     ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TcSplice ( finishTH )
 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import IfaceEnv( externaliseName )
@@ -56,11 +61,7 @@ import RnFixity ( lookupFixityRn )
 import MkId
 import TidyPgm    ( globaliseAndTidyId )
 import TysWiredIn ( unitTy, mkListTy )
-#if defined(GHCI)
-import DynamicLoading ( loadPlugins )
-import Plugins ( tcPlugin )
-#endif
-
+import Plugins
 import DynFlags
 import HsSyn
 import IfaceSyn ( ShowSub(..), showToHeader )
@@ -133,6 +134,7 @@ import Data.Data ( Data )
 import HsDumpAst
 import qualified Data.Set as S
 
+import Control.DeepSeq
 import Control.Monad
 
 #include "HsVersions.h"
@@ -147,12 +149,12 @@ import Control.Monad
 
 -- | Top level entry point for typechecker and renamer
 tcRnModule :: HscEnv
-           -> HscSource
+           -> ModSummary
            -> Bool              -- True <=> save renamed syntax
            -> HsParsedModule
            -> IO (Messages, Maybe TcGblEnv)
 
-tcRnModule hsc_env hsc_src save_rn_syntax
+tcRnModule hsc_env mod_sum save_rn_syntax
    parsedModule@HsParsedModule {hpm_module=L loc this_module}
  | RealSrcSpan real_loc <- loc
  = withTiming (pure dflags)
@@ -161,12 +163,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax
    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
           withTcPlugins hsc_env $
 
-          tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
+          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
 
   | otherwise
   = return ((emptyBag, unitBag err_msg), Nothing)
 
   where
+    hsc_src = ms_hsc_src mod_sum
     dflags = hsc_dflags hsc_env
     err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
               text "Module does not have a RealSrcSpan:" <+> ppr this_mod
@@ -185,13 +188,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 
 
 tcRnModuleTcRnM :: HscEnv
-                -> HscSource
+                -> ModSummary
                 -> HsParsedModule
                 -> (Module, SrcSpan)
                 -> TcRn TcGblEnv
 -- Factored out separately from tcRnModule so that a Core plugin can
 -- call the type checker directly
-tcRnModuleTcRnM hsc_env hsc_src
+tcRnModuleTcRnM hsc_env mod_sum
                 (HsParsedModule {
                    hpm_module =
                       (L loc (HsModule maybe_mod export_ies
@@ -201,8 +204,8 @@ tcRnModuleTcRnM hsc_env hsc_src
                 })
                 (this_mod, prel_imp_loc)
  = setSrcSpan loc $
-   do { let { explicit_mod_hdr = isJust maybe_mod } ;
-
+   do { let { explicit_mod_hdr = isJust maybe_mod
+            ; hsc_src = ms_hsc_src mod_sum };
                 -- Load the hi-boot interface for this module, if any
                 -- We do this now so that the boot_names can be passed
                 -- to tcTyAndClassDecls, because the boot_names are
@@ -239,7 +242,7 @@ tcRnModuleTcRnM hsc_env hsc_src
 
           -- If the whole module is warned about or deprecated
           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
-          -- a WarnAll, it will override any subseqent depracations added to tcg_warns
+          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
         let { tcg_env1 = case mod_deprec of
                          Just (L _ txt) -> tcg_env { tcg_warns = WarnAll txt }
                          Nothing        -> tcg_env
@@ -287,6 +290,8 @@ tcRnModuleTcRnM hsc_env hsc_src
                 -- add extra source files to tcg_dependent_files
         addDependentFiles src_files ;
 
+        tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env ;
+
                 -- Dump output and return
         tcDump tcg_env ;
         return tcg_env
@@ -364,13 +369,14 @@ tcRnImports hsc_env import_decls
 
                 -- Check type-family consistency between imports.
                 -- See Note [The type family instance consistency story]
-        ; traceRn "rn1: checking family instance consistency" empty
+        ; traceRn "rn1: checking family instance consistency {" empty
         ; let { dir_imp_mods = moduleEnvKeys
                              . imp_mods
                              $ imports }
-        ; tcg_env <- checkFamInstConsistency dir_imp_mods ;
+        ; checkFamInstConsistency dir_imp_mods
+        ; traceRn "rn1: } checking family instance consistency" empty
 
-        ; return tcg_env } }
+        ; getGblEnv } }
 
 {-
 ************************************************************************
@@ -385,14 +391,14 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> TcM TcGblEnv
 tcRnSrcDecls explicit_mod_hdr decls
  = do { -- Do all the declarations
-      ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $
-              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
+      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
 
-                   -- Check for the 'main' declaration
-                   -- Must do this inside the captureTopConstraints
-                 ; tcg_env <- setEnvs (tcg_env, tcl_env) $
-                              checkMain explicit_mod_hdr
-                 ; return (tcg_env, tcl_env) }
+        -- Check for the 'main' declaration
+        -- Must do this inside the captureTopConstraints
+      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
+                               -- always set envs *before* captureTopConstraints
+                               captureTopConstraints $
+                               checkMain explicit_mod_hdr
 
       ; setEnvs (tcg_env, tcl_env) $ do {
 
@@ -406,7 +412,7 @@ tcRnSrcDecls explicit_mod_hdr decls
              --  * the local env exposes the local Ids to simplifyTop,
              --    so that we get better error messages (monomorphism restriction)
       ; new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop lie
+                        simplifyTop (lie `andWC` lie_main)
 
         -- Emit Typeable bindings
       ; tcg_env <- mkTypeableBinds
@@ -433,13 +439,12 @@ tcRnSrcDecls explicit_mod_hdr decls
                          tcg_ev_binds  = cur_ev_binds,
                          tcg_imp_specs = imp_specs,
                          tcg_rules     = rules,
-                         tcg_vects     = vects,
                          tcg_fords     = fords } = tcg_env
             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 
-      ; (bind_env, ev_binds', binds', fords', imp_specs', rules', vects')
+      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
             <- {-# SCC "zonkTopDecls" #-}
-               zonkTopDecls all_ev_binds binds rules vects
+               zonkTopDecls all_ev_binds binds rules
                             imp_specs fords ;
       ; traceTc "Tc11" empty
 
@@ -448,7 +453,6 @@ tcRnSrcDecls explicit_mod_hdr decls
                                    tcg_ev_binds = ev_binds',
                                    tcg_imp_specs = imp_specs',
                                    tcg_rules    = rules',
-                                   tcg_vects    = vects',
                                    tcg_fords    = fords' } } ;
 
       ; setGlobalTypeEnv tcg_env' final_type_env
@@ -466,16 +470,17 @@ run_th_modfinalizers = do
   then getEnvs
   else do
     writeTcRef th_modfinalizers_var []
-    (envs, lie) <- captureTopConstraints $ do
-      sequence_ th_modfinalizers
-      -- Finalizers can add top-level declarations with addTopDecls.
-      tc_rn_src_decls []
-    setEnvs envs $ do
+    (_, lie_th) <- captureTopConstraints $
+                   sequence_ th_modfinalizers
+      -- Finalizers can add top-level declarations with addTopDecls, so
+      -- we have to run tc_rn_src_decls to get them
+    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
+    setEnvs (tcg_env, tcl_env) $ do
       -- Subsequent rounds of finalizers run after any new constraints are
       -- simplified, or some types might not be complete when using reify
       -- (see #12777).
       new_ev_binds <- {-# SCC "simplifyTop2" #-}
-                      simplifyTop lie
+                      simplifyTop (lie_th `andWC` lie_top_decls)
       updGblEnv (\tcg_env ->
         tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds }
         )
@@ -483,9 +488,10 @@ run_th_modfinalizers = do
         run_th_modfinalizers
 
 tc_rn_src_decls :: [LHsDecl GhcPs]
-                -> TcM (TcGblEnv, TcLclEnv)
+                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
 -- Loops around dealing with each top level inter-splice group
 -- in turn, until it's dealt with the entire module
+-- Never emits constraints; calls captureTopConstraints internally
 tc_rn_src_decls ds
  = {-# SCC "tc_rn_src_decls" #-}
    do { (first_group, group_tail) <- findSplice ds
@@ -509,9 +515,10 @@ tc_rn_src_decls ds
             else do { (th_group, th_group_tail) <- findSplice th_ds
                     ; case th_group_tail of
                         { Nothing -> return () ;
-                        ; Just (SpliceDecl (L loc _) _, _)
+                        ; Just (SpliceDecl _ (L loc _) _, _)
                             -> setSrcSpan loc $
                                addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls")
+                        ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
                         } ;
 
                     -- Rename TH-generated top-level declarations
@@ -529,16 +536,20 @@ tc_rn_src_decls ds
                     }
 
       -- Type check all declarations
-      ; (tcg_env, tcl_env) <- setGblEnv tcg_env $
-                              tcTopSrcDecls rn_decls
+      -- NB: set the env **before** captureTopConstraints so that error messages
+      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
+      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
+      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
+                                      captureTopConstraints $
+                                      tcTopSrcDecls rn_decls
 
         -- If there is no splice, we're nearly done
       ; setEnvs (tcg_env, tcl_env) $
         case group_tail of
-          { Nothing -> return (tcg_env, tcl_env)
+          { Nothing -> return (tcg_env, tcl_env, lie1)
 
             -- If there's a splice, we must carry on
-          ; Just (SpliceDecl (L loc splice) _, rest_ds) ->
+          ; Just (SpliceDecl _ (L loc splice) _, rest_ds) ->
             do { recordTopLevelSpliceLoc loc
 
                  -- Rename the splice expression, and get its supporting decls
@@ -546,9 +557,13 @@ tc_rn_src_decls ds
                                                              splice)
 
                  -- Glue them on the front of the remaining decls and loop
-               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
-                 tc_rn_src_decls (spliced_decls ++ rest_ds)
+               ; (tcg_env, tcl_env, lie2) <-
+                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+                   tc_rn_src_decls (spliced_decls ++ rest_ds)
+
+               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)
                }
+          ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
           }
       }
 
@@ -571,23 +586,24 @@ tcRnHsBootDecls hsc_src decls
                             , hs_fords  = for_decls
                             , hs_defds  = def_decls
                             , hs_ruleds = rule_decls
-                            , hs_vects  = vect_decls
                             , hs_annds  = _
-                            , hs_valds  = ValBindsOut val_binds val_sigs })
+                            , hs_valds
+                                 = XValBindsLR (NValBinds val_binds val_sigs) })
               <- rnTopSrcDecls first_group
         -- The empty list is for extra dependencies coming from .hs-boot files
         -- See Note [Extra dependencies from .hs-boot files] in RnSource
-        ; (gbl_env, lie) <- captureTopConstraints $ setGblEnv tcg_env $ do {
-
+        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
+              -- NB: setGblEnv **before** captureTopConstraints so that
+              -- if the latter reports errors, it knows what's in scope
 
                 -- Check for illegal declarations
         ; case group_tail of
-             Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d
+             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
+             Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"
              Nothing                  -> return ()
         ; mapM_ (badBootDecl hsc_src "foreign") for_decls
         ; mapM_ (badBootDecl hsc_src "default") def_decls
         ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
-        ; mapM_ (badBootDecl hsc_src "vect")    vect_decls
 
                 -- Typecheck type/class/instance decls
         ; traceTc "Tc2 (boot)" empty
@@ -1000,7 +1016,6 @@ checkBootTyCon is_boot tc1 tc2
   = ASSERT(tc1 == tc2)
     checkRoles roles1 roles2 `andThenCheck`
     check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
-
   -- This allows abstract 'data T a' to be implemented using 'type T = ...'
   -- and abstract 'class K a' to be implement using 'type K = ...'
   -- See Note [Synonyms implement abstract data]
@@ -1015,6 +1030,17 @@ checkBootTyCon is_boot tc1 tc2
     -- So for now, let it all through (it won't cause segfaults, anyway).
     -- Tracked at #12704.
 
+  -- This allows abstract 'data T :: Nat' to be implemented using
+  -- 'type T = 42' Since the kinds already match (we have checked this
+  -- upfront) all we need to check is that the implementation 'type T
+  -- = ...' defined an actual literal.  See #15138 for the case this
+  -- handles.
+  | not is_boot
+  , isAbstractTyCon tc1
+  , Just (_,ty2) <- synTyConDefn_maybe tc2
+  , isJust (isLitTy ty2)
+  = Nothing
+
   | Just fam_flav1 <- famTyConFlav_maybe tc1
   , Just fam_flav2 <- famTyConFlav_maybe tc2
   = ASSERT(tc1 == tc2)
@@ -1028,15 +1054,15 @@ checkBootTyCon is_boot tc1 tc2
             = eqClosedFamilyAx ax1 ax2
         eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
         eqFamFlav _ _ = False
-        injInfo1 = familyTyConInjectivityInfo tc1
-        injInfo2 = familyTyConInjectivityInfo tc2
+        injInfo1 = tyConInjectivityInfo tc1
+        injInfo2 = tyConInjectivityInfo tc2
     in
     -- check equality of roles, family flavours and injectivity annotations
     -- (NB: Type family roles are always nominal. But the check is
     -- harmless enough.)
     checkRoles roles1 roles2 `andThenCheck`
     check (eqFamFlav fam_flav1 fam_flav2)
-        (ifPprDebug $
+        (whenPprDebug $
             text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
             text "do not match") `andThenCheck`
     check (injInfo1 == injInfo2) (text "Injectivities do not match")
@@ -1298,6 +1324,8 @@ rnTopSrcDecls group
         traceRn "rn12" empty ;
         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
         traceRn "rn13" empty ;
+        (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
+        traceRn "rn13-plugin" empty ;
 
         -- save the renamed syntax, if we want it
         let { tcg_env'
@@ -1318,8 +1346,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                          hs_defds  = default_decls,
                          hs_annds  = annotation_decls,
                          hs_ruleds = rule_decls,
-                         hs_vects  = vect_decls,
-                         hs_valds  = hs_val_binds@(ValBindsOut val_binds val_sigs) })
+                         hs_valds  = hs_val_binds@(XValBindsLR
+                                              (NValBinds val_binds val_sigs)) })
  = do {         -- Type-check the type and class decls, and all imported decls
                 -- The latter come in via tycl_decls
         traceTc "Tc2 (src)" empty ;
@@ -1327,7 +1355,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Source-language instances, including derivings,
                 -- and import the supporting declarations
         traceTc "Tc3" empty ;
-        (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)
+        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
 
         setGblEnv tcg_env       $ do {
@@ -1380,9 +1408,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Rules
         rules <- tcRules rule_decls ;
 
-                -- Vectorisation declarations
-        vects <- tcVectDecls vect_decls ;
-
                 -- Wrap up
         traceTc "Tc7a" empty ;
         let { all_binds = inst_binds     `unionBags`
@@ -1401,7 +1426,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                                  , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names
                                  , tcg_rules   = tcg_rules tcg_env
                                                       ++ flattenRuleDecls rules
-                                 , tcg_vects   = tcg_vects tcg_env ++ vects
                                  , tcg_anns    = tcg_anns tcg_env ++ annotations
                                  , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
                                  , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
@@ -1672,7 +1696,7 @@ check_main dflags tcg_env explicit_mod_hdr
         ; (ev_binds, main_expr)
                <- checkConstraints skol_info [] [] $
                   addErrCtxt mainCtxt    $
-                  tcMonoExpr (L loc (HsVar (L loc main_name)))
+                  tcMonoExpr (L loc (HsVar noExt (L loc main_name)))
                              (mkCheckExpType io_ty)
 
                 -- See Note [Root-main Id]
@@ -1685,8 +1709,12 @@ check_main dflags tcg_env explicit_mod_hdr
               ; root_main_id = Id.mkExportedVanillaId root_main_name
                                                       (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
-              ; rhs = mkHsDictLet ev_binds $
-                      nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
+              -- The ev_binds of the `main` function may contain deferred
+              -- type error when type of `main` is not `IO a`. The `ev_binds`
+              -- must be put inside `runMainIO` to ensure the deferred type
+              -- error can be emitted correctly. See Trac #13838.
+              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
+                        mkHsDictLet ev_binds main_expr
               ; main_bind = mkVarBind root_main_id rhs }
 
         ; return (tcg_env { tcg_main  = Just main_name,
@@ -1783,8 +1811,8 @@ runTcInteractive hsc_env thing_inside
                                  (loadSrcInterface (text "runTcInteractive") m
                                                    False mb_pkg)
 
-       ; orphs <- fmap concat . forM (ic_imports icxt) $ \i ->
-            case i of
+       ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
+            case i of                   -- force above: see #15111
                 IIModule n -> getOrphans n Nothing
                 IIDecl i ->
                   let mb_pkg = sl_fs <$> ideclPkgQual i in
@@ -1793,6 +1821,7 @@ runTcInteractive hsc_env thing_inside
        ; let imports = emptyImportAvails {
                             imp_orphs = orphs
                         }
+
        ; (gbl_env, lcl_env) <- getEnvs
        ; let gbl_env' = gbl_env {
                            tcg_rdr_env      = ic_rn_gbl_env icxt
@@ -1847,7 +1876,7 @@ runTcInteractive hsc_env thing_inside
 
 {- Note [Initialising the type environment for GHCi]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most of the the Ids in ic_things, defined by the user in 'let' stmts,
+Most of the Ids in ic_things, defined by the user in 'let' stmts,
 have closed types. E.g.
    ghci> let foo x y = x && not y
 
@@ -1976,7 +2005,7 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
 tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
 
 -- An expression typed at the prompt is treated very specially
-tcUserStmt (L loc (BodyStmt expr _ _ _))
+tcUserStmt (L loc (BodyStmt _ expr _ _))
   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
                -- Don't try to typecheck if the renamer fails!
         ; ghciStep <- getGhciStepIO
@@ -1986,38 +2015,49 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
               matches   = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr
                                    (noLoc emptyLocalBinds)]
               -- [it = expr]
-              the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
+              the_bind  = L loc $ (mkTopFunBind FromSource
+                                     (L loc fresh_it) matches) { fun_ext = fvs }
                           -- Care here!  In GHCi the expression might have
                           -- free variables, and they in turn may have free type variables
                           -- (if we are at a breakpoint, say).  We must put those free vars
 
               -- [let it = expr]
-              let_stmt  = L loc $ LetStmt $ noLoc $ HsValBinds $
-                          ValBindsOut [(NonRecursive,unitBag the_bind)] []
+              let_stmt  = L loc $ LetStmt noExt $ noLoc $ HsValBinds noExt
+                           $ XValBindsLR
+                               (NValBinds [(NonRecursive,unitBag the_bind)] [])
 
               -- [it <- e]
-              bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it)))
-                                           (nlHsApp ghciStep rn_expr)
-                                           (mkRnSyntaxExpr bindIOName)
-                                           noSyntaxExpr
-                                           PlaceHolder
+              bind_stmt = L loc $ BindStmt noExt
+                                       (L loc (VarPat noExt (L loc fresh_it)))
+                                       (nlHsApp ghciStep rn_expr)
+                                       (mkRnSyntaxExpr bindIOName)
+                                       noSyntaxExpr
 
               -- [; print it]
-              print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
+              print_it  = L loc $ BodyStmt noExt
+                                           (nlHsApp (nlHsVar interPrintName)
+                                           (nlHsVar fresh_it))
                                            (mkRnSyntaxExpr thenIOName)
-                                                  noSyntaxExpr placeHolderType
+                                                  noSyntaxExpr
 
-        -- The plans are:
-        --   A. [it <- e; print it]     but not if it::()
-        --   B. [it <- e]
-        --   C. [let it = e; print it]
-        --
-        -- Ensure that type errors don't get deferred when type checking the
-        -- naked expression. Deferring type errors here is unhelpful because the
-        -- expression gets evaluated right away anyway. It also would potentially
-        -- emit two redundant type-error warnings, one from each plan.
-        ; plan <- unsetGOptM Opt_DeferTypeErrors $
-                  unsetGOptM Opt_DeferTypedHoles $ runPlans [
+              -- NewA
+              no_it_a = L loc $ BodyStmt noExt (nlHsApps bindIOName
+                                       [rn_expr , nlHsVar interPrintName])
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_b = L loc $ BodyStmt noExt (rn_expr)
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_c = L loc $ BodyStmt noExt
+                                      (nlHsApp (nlHsVar interPrintName) rn_expr)
+                                      (mkRnSyntaxExpr thenIOName)
+                                      noSyntaxExpr
+
+              -- See Note [GHCi Plans]
+
+              it_plans = [
                     -- Plan A
                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
                        ; it_ty <- zonkTcType (idType it_id)
@@ -2036,9 +2076,80 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
                                 --- checkNoErrs defeats the error recovery of let-bindings
                        ; tcGhciStmts [let_stmt, print_it] } ]
 
+              -- Plans where we don't bind "it"
+              no_it_plans = [
+                    tcGhciStmts [no_it_a] ,
+                    tcGhciStmts [no_it_b] ,
+                    tcGhciStmts [no_it_c] ]
+
+        ; generate_it <- goptM Opt_NoIt
+
+        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
+        -- See Note [Deferred type errors in GHCi]
+
+        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
+        -- and `-fdefer-out-of-scope-variables`. However the flag
+        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
+        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
+        -- also need to be unset here.
+        ; plan <- unsetGOptM Opt_DeferTypeErrors $
+                  unsetGOptM Opt_DeferTypedHoles $
+                  unsetGOptM Opt_DeferOutOfScopeVariables $
+                    runPlans $ if generate_it
+                                 then no_it_plans
+                                 else it_plans
+
         ; fix_env <- getFixityEnv
         ; return (plan, fix_env) }
 
+{- Note [Deferred type errors in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHCi, we ensure that type errors don't get deferred when type checking the
+naked expressions. Deferring type errors here is unhelpful because the
+expression gets evaluated right away anyway. It also would potentially emit
+two redundant type-error warnings, one from each plan.
+
+Trac #14963 reveals another bug that when deferred type errors is enabled
+in GHCi, any reference of imported/loaded variables (directly or indirectly)
+in interactively issued naked expressions will cause ghc panic. See more
+detailed dicussion in Trac #14963.
+
+The interactively issued declarations, statements, as well as the modules
+loaded into GHCi, are not affected. That means, for declaration, you could
+have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> x :: IO (); x = putStrLn True
+    <interactive>:14:26: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+
+But for naked expressions, you will have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> putStrLn True
+    <interactive>:2:10: error:
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘it’: it = putStrLn True
+
+    Prelude> let x = putStrLn True
+    <interactive>:2:18: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+-}
+
 tcUserStmt rdr_stmt@(L loc _)
   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
            rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
@@ -2050,8 +2161,8 @@ tcUserStmt rdr_stmt@(L loc _)
 
        ; ghciStep <- getGhciStepIO
        ; let gi_stmt
-               | (L loc (BindStmt pat expr op1 op2 ty)) <- rn_stmt
-                           = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 ty
+               | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
+                     = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2
                | otherwise = rn_stmt
 
        ; opt_pr_flag <- goptM Opt_PrintBindResult
@@ -2073,9 +2184,30 @@ tcUserStmt rdr_stmt@(L loc _)
            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
            ; return stuff }
       where
-        print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
+        print_v  = L loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)
+                                    (nlHsVar v))
                                     (mkRnSyntaxExpr thenIOName) noSyntaxExpr
-                                    placeHolderType
+
+{-
+Note [GHCi Plans]
+~~~~~~~~~~~~~~~~~
+When a user types an expression in the repl we try to print it in three different
+ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
+which can be used to refer to the result of the expression subsequently in the repl.
+
+The normal plans are :
+  A. [it <- e; print e]     but not if it::()
+  B. [it <- e]
+  C. [let it = e; print it]
+
+When -fno-it is set, the plans are:
+  A. [e >>= print]
+  B. [e]
+  C. [let it = e in print it]
+
+The reason for -fno-it is explained in #14336. `it` can lead to the repl
+leaking memory as it is repeatedly queried.
+-}
 
 -- | Typecheck the statements given and then return the results of the
 -- statement in the form 'IO [()]'.
@@ -2117,15 +2249,16 @@ tcGhciStmts stmts
                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
                 -- if they were overloaded, since they aren't applied to anything.)
             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
-                       (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
+                       (noLoc $ ExplicitList unitTy Nothing
+                                                            (map mk_item ids)) ;
             mk_item id = let ty_args = [idType id, unitTy] in
                          nlHsApp (nlHsTyApp unsafeCoerceId
-                                   (map (getRuntimeRep "tcGhciStmts") ty_args ++ ty_args))
+                                   (map getRuntimeRep ty_args ++ ty_args))
                                  (nlHsVar id) ;
             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
         } ;
         return (ids, mkHsDictLet (EvBinds const_binds) $
-                     noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty))
+                     noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
     }
 
 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
@@ -2136,13 +2269,15 @@ getGhciStepIO = do
     let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
         ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
 
-        step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)]
-                                     , hst_body  = nlHsFunTy ghciM ioM }
+        step_ty = noLoc $ HsForAllTy
+                     { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]
+                     , hst_xforall = noExt
+                     , hst_body  = nlHsFunTy ghciM ioM }
 
         stepTy :: LHsSigWcType GhcRn
         stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
 
-    return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy)
+    return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName))
 
 isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
 isGHCiMonad hsc_env ty
@@ -2191,9 +2326,9 @@ tcRnExpr hsc_env mode rdr_expr
                   else return expr_ty } ;
 
     -- Generalise
-    ((qtvs, dicts, _), lie_top) <- captureTopConstraints $
-                                   {-# SCC "simplifyInfer" #-}
-                                   simplifyInfer tclvl
+    ((qtvs, dicts, _, _), lie_top) <- captureTopConstraints $
+                                      {-# SCC "simplifyInfer" #-}
+                                      simplifyInfer tclvl
                                                  infer_mode
                                                  []    {- No sig vars -}
                                                  [(fresh_it, res_ty)]
@@ -2243,7 +2378,7 @@ tcRnType :: HscEnv
 tcRnType hsc_env normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
-    do { (HsWC { hswc_wcs = wcs, hswc_body = rn_type }, _fvs)
+    do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
                <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
                   -- The type can have wild cards, but no implicit
                   -- generalisation; e.g.   :kind (T _)
@@ -2253,13 +2388,17 @@ tcRnType hsc_env normalise rdr_type
         -- It can have any rank or kind
         -- First bring into scope any wildcards
        ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
-       ; (ty, kind) <- solveEqualities $
-                       tcWildCardBinders wcs  $ \ _ ->
-                       tcLHsType rn_type
+       ; ((ty, kind), lie)  <-
+                       captureConstraints $
+                       tcWildCardBinders wcs $ \ wcs' ->
+                       do { emitWildCardHoleConstraints wcs'
+                          ; tcLHsTypeUnsaturated rn_type }
+       ; _ <- checkNoErrs (simplifyInteractive lie)
 
        -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
+       ; kind <- zonkTcType kind
        ; kvs <- kindGeneralize kind
-       ; ty  <- zonkTcTypeToType emptyZonkEnv ty
+       ; ty  <- zonkTcTypeToType ty
 
        ; ty' <- if normalise
                 then do { fam_envs <- tcGetFamInstEnvs
@@ -2512,9 +2651,7 @@ loadUnqualIfaces hsc_env ictxt
 
 rnDump :: (Outputable a, Data a) => a -> TcRn ()
 -- Dump, with a banner, if -ddump-rn
-rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn))
-               ; traceOptTcRn Opt_D_dump_rn_ast
-                 (mkDumpDoc "Renamer" (text (showAstData NoBlankSrcSpan rn))) }
+rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }
 
 tcDump :: TcGblEnv -> TcRn ()
 tcDump env
@@ -2535,7 +2672,7 @@ tcDump env
     full_dump  = pprLHsBinds (tcg_binds env)
         -- NB: foreign x-d's have undefined's in their types;
         --     hence can't show the tc_fords
-    ast_dump = text (showAstData NoBlankSrcSpan (tcg_binds env))
+    ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)
 
 -- It's unpleasant having both pprModGuts and pprModDetails here
 pprTcGblEnv :: TcGblEnv -> SDoc
@@ -2543,14 +2680,12 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                         tcg_insts     = insts,
                         tcg_fam_insts = fam_insts,
                         tcg_rules     = rules,
-                        tcg_vects     = vects,
                         tcg_imports   = imports })
   = vcat [ ppr_types type_env
          , ppr_tycons fam_insts type_env
          , ppr_insts insts
          , ppr_fam_insts fam_insts
          , vcat (map ppr rules)
-         , vcat (map ppr vects)
          , text "Dependent modules:" <+>
                 pprUFM (imp_dep_mods imports) (ppr . sort)
          , text "Dependent packages:" <+>
@@ -2559,7 +2694,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                 -- wobbling in testsuite output
 
 ppr_types :: TypeEnv -> SDoc
-ppr_types type_env = sdocWithPprDebug $ \dbg ->
+ppr_types type_env = getPprDebug $ \dbg ->
   let
     ids = [id | id <- typeEnvIds type_env, want_sig id]
     want_sig id | dbg
@@ -2573,7 +2708,7 @@ ppr_types type_env = sdocWithPprDebug $ \dbg ->
   text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
 
 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
-ppr_tycons fam_insts type_env = sdocWithPprDebug $ \dbg ->
+ppr_tycons fam_insts type_env = getPprDebug $ \dbg ->
   let
     fi_tycons = famInstsRepTyCons fam_insts
     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
@@ -2623,7 +2758,7 @@ Type Checker Plugins
 
 withTcPlugins :: HscEnv -> TcM a -> TcM a
 withTcPlugins hsc_env m =
-  do plugins <- liftIO (loadTcPlugins hsc_env)
+  do let plugins = getTcPlugins (hsc_dflags hsc_env)
      case plugins of
        [] -> m  -- Common fast case
        _  -> do ev_binds_var <- newTcEvBinds
@@ -2641,13 +2776,45 @@ withTcPlugins hsc_env m =
     do s <- runTcPluginM start ev_binds_var
        return (solve s, stop s)
 
-loadTcPlugins :: HscEnv -> IO [TcPlugin]
-#if !defined(GHCI)
-loadTcPlugins _ = return []
-#else
-loadTcPlugins hsc_env =
- do named_plugins <- loadPlugins hsc_env
-    return $ catMaybes $ map load_plugin named_plugins
+getTcPlugins :: DynFlags -> [TcPlugin]
+getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
+  where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p)
+
+runRenamerPlugin :: TcGblEnv
+                 -> HsGroup GhcRn
+                 -> TcM (TcGblEnv, HsGroup GhcRn)
+runRenamerPlugin gbl_env hs_group = do
+    dflags <- getDynFlags
+    withPlugins dflags
+      (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
+      (gbl_env, hs_group)
+
+
+-- XXX: should this really be a Maybe X?  Check under which circumstances this
+-- can become a Nothing and decide whether this should instead throw an
+-- exception/signal an error.
+type RenamedStuff =
+        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
+                Maybe LHsDocString))
+
+-- | Extract the renamed information from TcGblEnv.
+getRenamedStuff :: TcGblEnv -> RenamedStuff
+getRenamedStuff tc_result
+  = fmap (\decls -> ( decls, tcg_rn_imports tc_result
+                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
+         (tcg_rn_decls tc_result)
+
+runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
+runTypecheckerPlugin sum hsc_env gbl_env = do
+    let dflags = hsc_dflags hsc_env
+    withPlugins dflags
+      (\p opts env -> mark_plugin_unsafe dflags
+                        >> typeCheckResultAction p opts sum env)
+      gbl_env
+
+mark_plugin_unsafe :: DynFlags -> TcM ()
+mark_plugin_unsafe dflags = recordUnsafeInfer pluginUnsafe
   where
-    load_plugin (_, plug, opts) = tcPlugin plug opts
-#endif
+    unsafeText = "Use of plugins makes the module unsafe"
+    pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
+                                   (Outputable.text unsafeText) )
diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot
index e73855e033..6ffc409e22 100644
--- a/compiler/typecheck/TcRnDriver.hs-boot
+++ b/compiler/typecheck/TcRnDriver.hs-boot
@@ -1,5 +1,6 @@
 module TcRnDriver where
 
+import GhcPrelude
 import DynFlags (DynFlags)
 import Type (TyThing)
 import TcRnTypes (TcM)
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index ec099582a1..dbe2b4b22b 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -5,12 +5,13 @@
 {-# LANGUAGE TypeFamilies #-}
 module TcRnExports (tcRnExports, exports_from_avail) where
 
+import GhcPrelude
+
 import HsSyn
 import PrelNames
 import RdrName
 import TcRnMonad
 import TcEnv
-import TcMType
 import TcType
 import RnNames
 import RnEnv
@@ -30,7 +31,6 @@ import Outputable
 import ConLike
 import DataCon
 import PatSyn
-import FastString
 import Maybes
 import Util (capitalise)
 
@@ -91,13 +91,13 @@ You just have to use an explicit export list:
 data ExportAccum        -- The type of the accumulating parameter of
                         -- the main worker function in rnExports
      = ExportAccum
-        [LIE GhcRn]            --  Export items with Names
+        [(LIE GhcRn, Avails)] -- Export items with names and
+                                   -- their exported stuff
+                                   --   Not nub'd!
         ExportOccMap           --  Tracks exported occurrence names
-        [AvailInfo]            --  The accumulated exported stuff
-                               --   Not nub'd!
 
 emptyExportAccum :: ExportAccum
-emptyExportAccum = ExportAccum [] emptyOccEnv []
+emptyExportAccum = ExportAccum [] emptyOccEnv
 
 type ExportOccMap = OccEnv (Name, IE GhcPs)
         -- Tracks what a particular exported OccName
@@ -135,8 +135,8 @@ tcRnExports explicit_mod exports
                  | explicit_mod = exports
                  | ghcLink dflags == LinkInMemory = Nothing
                  | otherwise
-                          = Just (noLoc [noLoc
-                              (IEVar (noLoc (IEName $ noLoc main_RDR_Unqual)))])
+                          = Just (noLoc [noLoc (IEVar noExt
+                                     (noLoc (IEName $ noLoc main_RDR_Unqual)))])
                         -- ToDo: the 'noLoc' here is unhelpful if 'main'
                         --       turns out to be out of scope
 
@@ -170,16 +170,25 @@ exports_from_avail :: Maybe (Located [LIE GhcPs])
                          -- 'module Foo' export is valid (it's not valid
                          -- if we didn't import Foo!)
                    -> Module
-                   -> RnM (Maybe [LIE GhcRn], [AvailInfo])
+                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
+                         -- (Nothing, _) <=> no explicit export list
+                         -- if explicit export list is present it contains
+                         -- each renamed export item together with its exported
+                         -- names.
 
 exports_from_avail Nothing rdr_env _imports _this_mod
    -- The same as (module M) where M is the current module name,
    -- so that's how we handle it, except we also export the data family
    -- when a data instance is exported.
-  = let avails =
-          map fix_faminst . gresToAvailInfo
-            . filter isLocalGRE . globalRdrEnvElts $ rdr_env
-    in return (Nothing, avails)
+  = do {
+    ; warnMissingExportList <- woptM Opt_WarnMissingExportList
+    ; warnIfFlag Opt_WarnMissingExportList
+        warnMissingExportList
+        (missingModuleExportWarn $ moduleName _this_mod)
+    ; let avails =
+            map fix_faminst . gresToAvailInfo
+              . filter isLocalGRE . globalRdrEnvElts $ rdr_env
+    ; return (Nothing, avails) }
   where
     -- #11164: when we define a data instance
     -- but not data family, re-export the family
@@ -197,10 +206,10 @@ exports_from_avail Nothing rdr_env _imports _this_mod
 
 
 exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-  = do ExportAccum ie_names _ exports
+  = do ExportAccum ie_avails _
         <-  foldAndRecoverM do_litem emptyExportAccum rdr_items
-       let final_exports = nubAvails exports -- Combine families
-       return (Just ie_names, final_exports)
+       let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families
+       return (Just ie_avails, final_exports)
   where
     do_litem :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
     do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
@@ -215,10 +224,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                        , imv <- importedByUser xs ]
 
     exports_from_item :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
-    exports_from_item acc@(ExportAccum ie_names occs exports)
-                      (L loc (IEModuleContents (L lm mod)))
-        | let earlier_mods = [ mod
-                             | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
+    exports_from_item acc@(ExportAccum ie_avails occs)
+                      (L loc ie@(IEModuleContents _ (L lm mod)))
+        | let earlier_mods
+                = [ mod
+                  | ((L _ (IEModuleContents _ (L _ mod))), _) <- ie_avails ]
         , mod `elem` earlier_mods    -- Duplicate export of M
         = do { warnIfFlag Opt_WarnDuplicateExports True
                           (dupModuleExport mod) ;
@@ -229,9 +239,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                                 || (moduleName this_mod == mod)
                    ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
                    ; new_exports = map (availFromGRE . fst) gre_prs
-                   ; names       = map (gre_name     . fst) gre_prs
                    ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
-               }
+                   }
 
              ; checkErr exportValid (moduleNotImported mod)
              ; warnIfFlag Opt_WarnDodgyExports
@@ -241,7 +250,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
              ; traceRn "efa" (ppr mod $$ ppr all_gres)
              ; addUsedGREs all_gres
 
-             ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
+             ; occs' <- check_occs ie occs new_exports
                       -- This check_occs not only finds conflicts
                       -- between this item and others, but also
                       -- internally within this item.  That is, if
@@ -251,14 +260,14 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
              ; traceRn "export_mod"
                        (vcat [ ppr mod
                              , ppr new_exports ])
-             ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)
-                                   occs'
-                                   (new_exports ++ exports)) }
 
-    exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie)
+             ; return (ExportAccum (((L loc (IEModuleContents noExt (L lm mod)))
+                                    , new_exports) : ie_avails) occs') }
+
+    exports_from_item acc@(ExportAccum lie_avails occs) (L loc ie)
         | isDoc ie
         = do new_ie <- lookup_doc_ie ie
-             return (ExportAccum (L loc new_ie : lie_names) occs exports)
+             return (ExportAccum ((L loc new_ie, []) : lie_avails) occs)
 
         | otherwise
         = do (new_ie, avail) <-
@@ -267,29 +276,30 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                   then return acc    -- Avoid error cascade
                   else do
 
-                    occs' <- check_occs ie occs (availNames avail)
+                    occs' <- check_occs ie occs [avail]
 
-                    return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports))
+                    return (ExportAccum ((L loc new_ie, [avail]) : lie_avails) occs')
 
     -------------
     lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
-    lookup_ie (IEVar (L l rdr))
+    lookup_ie (IEVar _ (L l rdr))
         = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
-             return (IEVar (L l (replaceWrappedName rdr name)), avail)
+             return (IEVar noExt (L l (replaceWrappedName rdr name)), avail)
 
-    lookup_ie (IEThingAbs (L l rdr))
+    lookup_ie (IEThingAbs _ (L l rdr))
         = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
-             return (IEThingAbs (L l (replaceWrappedName rdr name)), avail)
+             return (IEThingAbs noExt (L l (replaceWrappedName rdr name))
+                    , avail)
 
-    lookup_ie ie@(IEThingAll n')
+    lookup_ie ie@(IEThingAll _ n')
         = do
             (n, avail, flds) <- lookup_ie_all ie n'
             let name = unLoc n
-            return (IEThingAll (replaceLWrappedName n' (unLoc n))
+            return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))
                    , AvailTC name (name:avail) flds)
 
 
-    lookup_ie ie@(IEThingWith l wc sub_rdrs _)
+    lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
         = do
             (lname, subs, avails, flds)
               <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
@@ -298,28 +308,27 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
                 NoIEWildcard -> return (lname, [], [])
                 IEWildcard _ -> lookup_ie_all ie l
             let name = unLoc lname
-                subs' = map (replaceLWrappedName l . unLoc) subs
-            return (IEThingWith (replaceLWrappedName l name) wc subs'
-                                (map noLoc (flds ++ all_flds)),
+            return (IEThingWith noExt (replaceLWrappedName l name) wc subs
+                                (flds ++ (map noLoc all_flds)),
                     AvailTC name (name : avails ++ all_avail)
-                                 (flds ++ all_flds))
-
-
+                                 (map unLoc flds ++ all_flds))
 
 
     lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
 
+
     lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
-                   -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
+                   -> RnM (Located Name, [LIEWrappedName Name], [Name],
+                           [Located FieldLabel])
     lookup_ie_with (L l rdr) sub_rdrs
         = do name <- lookupGlobalOccRn $ ieWrappedName rdr
-             (non_flds, flds) <- lookupChildrenExport name
-                                                  (map ieLWrappedName sub_rdrs)
+             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
              if isUnboundName name
                 then return (L l name, [], [name], [])
                 else return (L l name, non_flds
-                            , map unLoc non_flds
-                            , map unLoc flds)
+                            , map (ieWrappedName . unLoc) non_flds
+                            , flds)
+
     lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
                   -> RnM (Located Name, [Name], [FieldLabel])
     lookup_ie_all ie (L l rdr) =
@@ -340,11 +349,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
 
     -------------
     lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
-    lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
-                                         return (IEGroup lev rn_doc)
-    lookup_doc_ie (IEDoc doc)       = do rn_doc <- rnHsDoc doc
-                                         return (IEDoc rn_doc)
-    lookup_doc_ie (IEDocNamed str)  = return (IEDocNamed str)
+    lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc
+                                           return (IEGroup noExt lev rn_doc)
+    lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc
+                                           return (IEDoc noExt rn_doc)
+    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExt str)
     lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier
 
     -- In an export item M.T(A,B,C), we want to treat the uses of
@@ -365,9 +374,9 @@ classifyGRE gre = case gre_par gre of
     n = gre_name gre
 
 isDoc :: IE GhcPs -> Bool
-isDoc (IEDoc _)      = True
-isDoc (IEDocNamed _) = True
-isDoc (IEGroup _ _)  = True
+isDoc (IEDoc {})      = True
+isDoc (IEDocNamed {}) = True
+isDoc (IEGroup {})    = True
 isDoc _ = False
 
 -- Renaming and typechecking of exports happens after everything else has
@@ -400,9 +409,9 @@ isDoc _ = False
 
 
 
-lookupChildrenExport :: Name -> [Located RdrName]
-                     -> RnM ([Located Name], [Located FieldLabel])
-lookupChildrenExport parent rdr_items =
+lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
+                     -> RnM ([LIEWrappedName Name], [Located FieldLabel])
+lookupChildrenExport spec_parent rdr_items =
   do
     xs <- mapAndReportM doOne rdr_items
     return $ partitionEithers xs
@@ -416,16 +425,16 @@ lookupChildrenExport parent rdr_items =
           | ns == tcName  = [dataName, tcName]
           | otherwise = [ns]
         -- Process an individual child
-        doOne :: Located RdrName
-              -> RnM (Either (Located Name) (Located FieldLabel))
+        doOne :: LIEWrappedName RdrName
+              -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
         doOne n = do
 
-          let bareName = unLoc n
+          let bareName = (ieWrappedName . unLoc) n
               lkup v = lookupSubBndrOcc_helper False True
-                        parent (setRdrNameSpace bareName v)
+                        spec_parent (setRdrNameSpace bareName v)
 
-          name <-  combineChildLookupResult . map lkup $
-                    choosePossibleNamespaces (rdrNameSpace bareName)
+          name <-  combineChildLookupResult $ map lkup $
+                   choosePossibleNamespaces (rdrNameSpace bareName)
           traceRn "lookupChildrenExport" (ppr name)
           -- Default to data constructors for slightly better error
           -- messages
@@ -434,30 +443,16 @@ lookupChildrenExport parent rdr_items =
                                 then bareName
                                 else setRdrNameSpace bareName dataName
 
-          -- Might need to check here for FLs as well
-          name' <- case name of
-                     FoundName NoParent n -> checkPatSynParent parent n
-                     _ -> return name
-
-          traceRn "lookupChildrenExport" (ppr name')
-
-          case name' of
-            NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName
+          case name of
+            NameNotFound -> do { ub <- reportUnboundName unboundName
+                               ; let l = getLoc n
+                               ; return (Left (L l (IEName (L l ub))))}
             FoundFL fls -> return $ Right (L (getLoc n) fls)
-            FoundName _p name -> return $ Left (L (getLoc n) name)
-            NameErr err_msg -> reportError err_msg >> failM
-            IncorrectParent p g td gs -> do
-              mkDcErrMsg p g td gs >>= reportError
-              failM
-
-
--- | Also captures the current context
-mkNameErr :: SDoc -> TcM ChildLookupResult
-mkNameErr errMsg = NameErr <$> mkErrTc errMsg
+            FoundName par name -> do { checkPatSynParent spec_parent par name
+                                     ; return $ Left (replaceLWrappedName n name) }
+            IncorrectParent p g td gs -> failWithDcErr p g td gs
 
 
-
---
 -- Note: [Typing Pattern Synonym Exports]
 -- It proved quite a challenge to precisely specify which pattern synonyms
 -- should be allowed to be bundled with which type constructors.
@@ -514,58 +509,68 @@ mkNameErr errMsg = NameErr <$> mkErrTc errMsg
 -- whether we are allowed to export the child with the parent.
 -- Invariant: gre_par == NoParent
 -- See note [Typing Pattern Synonym Exports]
-checkPatSynParent    :: Name   -- ^ Type constructor
-                     -> Name   -- ^ Either a
-                               --   a) Pattern Synonym Constructor
-                               --   b) A pattern synonym selector
-               -> TcM ChildLookupResult
-checkPatSynParent parent mpat_syn
+checkPatSynParent :: Name    -- ^ Alleged parent type constructor
+                             -- User wrote T( P, Q )
+                  -> Parent  -- The parent of P we discovered
+                  -> Name    -- ^ Either a
+                             --   a) Pattern Synonym Constructor
+                             --   b) A pattern synonym selector
+                  -> TcM ()  -- Fails if wrong parent
+checkPatSynParent _ (ParentIs {}) _
+  = return ()
+
+checkPatSynParent _ (FldParent {}) _
+  = return ()
+
+checkPatSynParent parent NoParent mpat_syn
   | isUnboundName parent -- Avoid an error cascade
-  = return (FoundName NoParent mpat_syn)
-  | otherwise = do
-  parent_ty_con <- tcLookupTyCon parent
-  mpat_syn_thing <- tcLookupGlobal mpat_syn
-  let expected_res_ty =
-          mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con))
-
-      handlePatSyn errCtxt =
-        addErrCtxt errCtxt
-        . tc_one_ps_export_with expected_res_ty parent_ty_con
-  -- 1. Check that the Id was actually from a thing associated with patsyns
-  case mpat_syn_thing of
-      AnId i
-        | isId i               ->
-        case idDetails i of
-          RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p
-          _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
-      AConLike (PatSynCon p)    ->  handlePatSyn (psErr p) p
-      _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
-  where
+  = return ()
 
-    psErr = exportErrCtxt "pattern synonym"
+  | otherwise
+  = do { parent_ty_con <- tcLookupTyCon parent
+       ; mpat_syn_thing <- tcLookupGlobal mpat_syn
+
+        -- 1. Check that the Id was actually from a thing associated with patsyns
+       ; case mpat_syn_thing of
+            AnId i | isId i
+                   , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
+                   -> handle_pat_syn (selErr i) parent_ty_con p
+
+            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
+
+            _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
+  where
+    psErr  = exportErrCtxt "pattern synonym"
     selErr = exportErrCtxt "pattern synonym record selector"
 
     assocClassErr :: SDoc
-    assocClassErr =
-      text "Pattern synonyms can be bundled only with datatypes."
+    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
 
-    tc_one_ps_export_with :: TcTauType -- ^ TyCon type
-                       -> TyCon       -- ^ Parent TyCon
-                       -> PatSyn   -- ^ Corresponding bundled PatSyn
-                                           -- and pretty printed origin
-                       -> TcM ChildLookupResult
-    tc_one_ps_export_with expected_res_ty ty_con pat_syn
+    handle_pat_syn :: SDoc
+                   -> TyCon      -- ^ Parent TyCon
+                   -> PatSyn     -- ^ Corresponding bundled PatSyn
+                                 --   and pretty printed origin
+                   -> TcM ()
+    handle_pat_syn doc ty_con pat_syn
 
       -- 2. See note [Types of TyCon]
-      | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr
+      | not $ isTyConWithSrcDataCons ty_con
+      = addErrCtxt doc $ failWithTc assocClassErr
+
       -- 3. Is the head a type variable?
-      | Nothing <- mtycon = return (FoundName (ParentIs parent) mpat_syn)
+      | Nothing <- mtycon
+      = return ()
       -- 4. Ok. Check they are actually the same type constructor.
-      | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError
+
+      | Just p_ty_con <- mtycon, p_ty_con /= ty_con
+      = addErrCtxt doc $ failWithTc typeMismatchError
+
       -- 5. We passed!
-      | otherwise = return (FoundName (ParentIs parent) mpat_syn)
+      | otherwise
+      = return ()
 
       where
+        expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
         (_, _, _, _, _, res_ty) = patSynSig pat_syn
         mtycon = fst <$> tcSplitTyConApp_maybe res_ty
         typeMismatchError :: SDoc
@@ -577,16 +582,22 @@ checkPatSynParent parent mpat_syn
               <+> quotes (ppr res_ty)
 
 
-
-
 {-===========================================================================-}
-
-
-check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> RnM ExportOccMap
-check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
-  = foldlM check occs names
+check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
+           -> RnM ExportOccMap
+check_occs ie occs avails
+  -- 'names' and 'fls' are the entities specified by 'ie'
+  = foldlM check occs names_with_occs
   where
-    check occs name
+    -- Each Name specified by 'ie', paired with the OccName used to
+    -- refer to it in the GlobalRdrEnv
+    -- (see Note [Representing fields in AvailInfo] in Avail).
+    --
+    -- We check for export clashes using the selector Name, but need
+    -- the field label OccName for presenting error messages.
+    names_with_occs = availsNamesWithOccs avails
+
+    check occs (name, occ)
       = case lookupOccEnv occs name_occ of
           Nothing -> return (extendOccEnv occs name_occ (name, ie))
 
@@ -596,12 +607,12 @@ check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
             -- by two different module exports. See ticket #4478.
             -> do { warnIfFlag Opt_WarnDuplicateExports
                                (not (dupExport_ok name ie ie'))
-                               (dupExportWarn name_occ ie ie')
+                               (dupExportWarn occ ie ie')
                   ; return occs }
 
             | otherwise    -- Same occ name but different names: an error
             ->  do { global_env <- getGlobalRdrEnv ;
-                     addErr (exportClashErr global_env name' name ie' ie) ;
+                     addErr (exportClashErr global_env occ name' name ie' ie) ;
                      return occs }
       where
         name_occ = nameOccName name
@@ -638,8 +649,8 @@ dupExport_ok n ie1 ie2
   = not (  single ie1 || single ie2
         || (explicit_in ie1 && explicit_in ie2) )
   where
-    explicit_in (IEModuleContents _) = False                   -- module M
-    explicit_in (IEThingAll r)
+    explicit_in (IEModuleContents {}) = False                   -- module M
+    explicit_in (IEThingAll _ r)
       = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)
     explicit_in _              = True
 
@@ -656,12 +667,21 @@ dupModuleExport mod
 
 moduleNotImported :: ModuleName -> SDoc
 moduleNotImported mod
-  = text "The export item `module" <+> ppr mod <>
-    text "' is not imported"
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is not imported"]
 
 nullModuleExport :: ModuleName -> SDoc
 nullModuleExport mod
-  = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing")
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "exports nothing"]
+
+missingModuleExportWarn :: ModuleName -> SDoc
+missingModuleExportWarn mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is missing an export list"]
 
 
 dodgyExportWarn :: Name -> SDoc
@@ -673,7 +693,8 @@ exportErrCtxt herald exp =
   text "In the" <+> text (herald ++ ":") <+> ppr exp
 
 
-addExportErrCtxt :: (OutputableBndrId s) => IE s -> TcM a -> TcM a
+addExportErrCtxt :: (OutputableBndrId (GhcPass p))
+                 => IE (GhcPass p) -> TcM a -> TcM a
 addExportErrCtxt ie = addErrCtxt exportCtxt
   where
     exportCtxt = text "In the export:" <+> ppr ie
@@ -702,11 +723,11 @@ dcErrMsg ty_con what_is thing parents =
                       [_] -> text "Parent:"
                       _  -> text "Parents:") <+> fsep (punctuate comma parents)
 
-mkDcErrMsg :: Name -> Name -> SDoc -> [Name] -> TcM ErrMsg
-mkDcErrMsg parent thing thing_doc parents = do
+failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
+failWithDcErr parent thing thing_doc parents = do
   ty_thing <- tcLookupGlobal thing
-  mkErrTc $
-    dcErrMsg parent (tyThingCategory' ty_thing) thing_doc (map ppr parents)
+  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
+                        thing_doc (map ppr parents)
   where
     tyThingCategory' :: TyThing -> String
     tyThingCategory' (AnId i)
@@ -714,21 +735,29 @@ mkDcErrMsg parent thing thing_doc parents = do
     tyThingCategory' i = tyThingCategory i
 
 
-exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE GhcPs -> IE GhcPs
+exportClashErr :: GlobalRdrEnv -> OccName
+               -> Name -> Name
+               -> IE GhcPs -> IE GhcPs
                -> MsgDoc
-exportClashErr global_env name1 name2 ie1 ie2
+exportClashErr global_env occ name1 name2 ie1 ie2
   = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
          , ppr_export ie1' name1'
          , ppr_export ie2' name2' ]
   where
-    occ = nameOccName name1
     ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
-                                       quotes (ppr name))
+                                       quotes (ppr_name name))
                                     2 (pprNameProvenance (get_gre name)))
 
+    -- DuplicateRecordFields means that nameOccName might be a mangled
+    -- $sel-prefixed thing, in which case show the correct OccName alone
+    ppr_name name
+      | nameOccName name == occ = ppr name
+      | otherwise               = ppr occ
+
     -- get_gre finds a GRE for the Name, so that we can show its provenance
     get_gre name
-        = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name)
+        = fromMaybe (pprPanic "exportClashErr" (ppr name))
+                    (lookupGRE_Name_OccName global_env name occ)
     get_loc name = greSrcSpan (get_gre name)
     (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
                                    then (name1, ie1, name2, ie2)
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index a6a995de1a..aa95c1eb2e 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -5,12 +5,13 @@
 Functions for working with the typechecker environment (setters, getters...).
 -}
 
-{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
+{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module TcRnMonad(
   -- * Initalisation
-  initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf,
+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
 
   -- * Simple accessors
   discardResult,
@@ -19,7 +20,8 @@ module TcRnMonad(
   getEnvs, setEnvs,
   xoptM, doptM, goptM, woptM,
   setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
-  whenDOptM, whenGOptM, whenWOptM, whenXOptM,
+  whenDOptM, whenGOptM, whenWOptM,
+  whenXOptM, unlessXOptM,
   getGhcMode,
   withDoDynamicToo,
   getEpsVar,
@@ -84,19 +86,19 @@ module TcRnMonad(
   failIfTc, failIfTcM,
   warnIfFlag, warnIf, warnTc, warnTcM,
   addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
-  tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
+  mkErrInfo,
 
   -- * Type constraints
-  newTcEvBinds,
+  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
   addTcEvBind,
-  getTcEvTyCoVars, getTcEvBindsMap,
+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
   chooseUniqueOccTc,
   getConstraintVar, setConstraintVar,
   emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
   emitImplication, emitImplications, emitInsoluble,
   discardConstraints, captureConstraints, tryCaptureConstraints,
   pushLevelAndCaptureConstraints,
-  pushTcLevelM_, pushTcLevelM,
+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
   getTcLevel, setTcLevel, isTouchableTcM,
   getLclTypeEnv, setLclTypeEnv,
   traceTcConstraints, emitWildCardHoleConstraints,
@@ -127,6 +129,9 @@ module TcRnMonad(
 
   withException,
 
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
   -- * Types etc.
   module TcRnTypes,
   module IOEnv
@@ -134,6 +139,8 @@ module TcRnMonad(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes        -- Re-export all
 import IOEnv            -- Re-export all
 import TcEvidence
@@ -167,16 +174,18 @@ import Util
 import Annotations
 import BasicTypes( TopLevelFlag )
 import Maybes
+import CostCentreState
 
 import qualified GHC.LanguageExtensions as LangExt
 
-import Control.Exception
 import Data.IORef
 import Control.Monad
 import Data.Set ( Set )
 import qualified Data.Set as Set
 
 import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
+import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )
+
 import qualified Data.Map as Map
 
 {-
@@ -212,10 +221,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
         dependent_files_var <- newIORef [] ;
         static_wc_var       <- newIORef emptyWC ;
+        cc_st_var           <- newIORef newCostCentreState ;
         th_topdecls_var      <- newIORef [] ;
         th_foreign_files_var <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
         th_modfinalizers_var <- newIORef [] ;
+        th_coreplugins_var <- newIORef [] ;
         th_state_var         <- newIORef Map.empty ;
         th_remote_state_var  <- newIORef Nothing ;
         let {
@@ -223,22 +234,28 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
              maybe_rn_syntax :: forall a. a -> Maybe a ;
              maybe_rn_syntax empty_val
-                | keep_rn_syntax = Just empty_val
-                | otherwise      = Nothing ;
+                | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+                  -- We want to serialize the documentation in the .hi-files,
+                  -- and need to extract it from the renamed syntax first.
+                  -- See 'ExtractDocs.extractDocs'.
+                | gopt Opt_Haddock dflags       = Just empty_val
+
+                | keep_rn_syntax                = Just empty_val
+                | otherwise                     = Nothing ;
 
              gbl_env = TcGblEnv {
                 tcg_th_topdecls      = th_topdecls_var,
                 tcg_th_foreign_files = th_foreign_files_var,
                 tcg_th_topnames      = th_topnames_var,
                 tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_coreplugins = th_coreplugins_var,
                 tcg_th_state         = th_state_var,
                 tcg_th_remote_state  = th_remote_state_var,
 
                 tcg_mod            = mod,
                 tcg_semantic_mod   =
-                    if thisPackage dflags == moduleUnitId mod
-                        then canonicalizeHomeModule dflags (moduleName mod)
-                        else mod,
+                    canonicalizeModuleIfHome dflags mod,
                 tcg_src            = hsc_src,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
@@ -250,7 +267,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_type_env_var   = type_env_var,
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
-                tcg_pending_fam_checks = emptyNameEnv,
                 tcg_ann_env        = emptyAnnEnv,
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
@@ -281,7 +297,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_fam_insts      = [],
                 tcg_rules          = [],
                 tcg_fords          = [],
-                tcg_vects          = [],
                 tcg_patsyns        = [],
                 tcg_merged         = [],
                 tcg_dfun_n         = dfun_n_var,
@@ -295,7 +310,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_tc_plugins     = [],
                 tcg_top_loc        = loc,
                 tcg_static_wc      = static_wc_var,
-                tcg_complete_matches = []
+                tcg_complete_matches = [],
+                tcg_cc_st          = cc_st_var
              } ;
         } ;
 
@@ -323,7 +339,6 @@ initTcWithGbl hsc_env gbl_env loc do_this
                 tcl_arrow_ctxt = NoArrowCtxt,
                 tcl_env        = emptyNameEnv,
                 tcl_bndrs      = [],
-                tcl_tidy       = emptyTidyEnv,
                 tcl_tyvars     = tvs_var,
                 tcl_lie        = lie_var,
                 tcl_tclvl      = topTcLevel
@@ -364,15 +379,6 @@ initTcInteractive hsc_env thing_inside
   where
     interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
 
-initTcForLookup :: HscEnv -> TcM a -> IO a
--- The thing_inside is just going to look up something
--- in the environment, so we don't need much setup
-initTcForLookup hsc_env thing_inside
-  = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
-       ; case m of
-             Nothing -> throwIO $ mkSrcErr $ snd msgs
-             Just x -> return x }
-
 {- Note [Default types]
 ~~~~~~~~~~~~~~~~~~~~~~~
 The Integer type is simply not available in package ghc-prim (it is
@@ -427,7 +433,7 @@ updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
                           env { env_top = upd top })
 
 getGblEnv :: TcRnIf gbl lcl gbl
-getGblEnv = do { env <- getEnv; return (env_gbl env) }
+getGblEnv = do { Env{..} <- getEnv; return env_gbl }
 
 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
@@ -437,7 +443,7 @@ setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 
 getLclEnv :: TcRnIf gbl lcl lcl
-getLclEnv = do { env <- getEnv; return (env_lcl env) }
+getLclEnv = do { Env{..} <- getEnv; return env_lcl }
 
 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
@@ -499,6 +505,10 @@ whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 whenXOptM flag thing_inside = do b <- xoptM flag
                                  when b thing_inside
 
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+                                   unless b thing_inside
+
 getGhcMode :: TcRnIf gbl lcl GhcMode
 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 
@@ -1293,19 +1303,6 @@ add_warn_at reason loc msg extra_info
                                     msg extra_info } ;
          reportWarning reason warn }
 
-tcInitTidyEnv :: TcM TidyEnv
-tcInitTidyEnv
-  = do  { lcl_env <- getLclEnv
-        ; return (tcl_tidy lcl_env) }
-
--- | Get a 'TidyEnv' that includes mappings for all vars free in the given
--- type. Useful when tidying open types.
-tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
-tcInitOpenTidyEnv tvs
-  = do { env1 <- tcInitTidyEnv
-       ; let env2 = tidyFreeTyCoVars env1 tvs
-       ; return env2 }
-
 
 {-
 -----------------------------------
@@ -1367,13 +1364,47 @@ newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
                                        , ebv_tcvs = tcvs_ref
                                        , ebv_uniq = uniq }) }
 
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; uniq <- newUnique
+       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
+                              , ebv_uniq = uniq }) }
+
+cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
+-- Clone the refs, so that any binding created when
+-- solving don't pollute the original
+cloneEvBindsVar ebv@(EvBindsVar {})
+  = do { binds_ref <- newTcRef emptyEvBindMap
+       ; tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_binds = binds_ref
+                     , ebv_tcvs = tcvs_ref }) }
+cloneEvBindsVar ebv@(CoEvBindsVar {})
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_tcvs = tcvs_ref }) }
+
 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
-getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })
-  = readTcRef ev_ref
+getTcEvTyCoVars ev_binds_var
+  = readTcRef (ebv_tcvs ev_binds_var)
 
 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
   = readTcRef ev_ref
+getTcEvBindsMap (CoEvBindsVar {})
+  = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+  = writeTcRef ev_ref binds
+setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
+  | isEmptyEvBindMap ev_binds
+  = return ()
+  | otherwise
+  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
 
 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
 -- Add a binding to the TcEvBinds by side effect
@@ -1382,6 +1413,8 @@ addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
                                  ppr ev_bind
        ; bnds <- readTcRef ev_ref
        ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
+addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
+  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
 
 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 chooseUniqueOccTc fn =
@@ -1478,6 +1511,7 @@ captureConstraints thing_inside
            Left _    -> do { emitConstraints lie; failM }
            Right res -> return (res, lie) }
 
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
 pushLevelAndCaptureConstraints thing_inside
   = do { env <- getLclEnv
@@ -1498,6 +1532,15 @@ pushTcLevelM thing_inside
                           thing_inside
        ; return (res, tclvl') }
 
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                thing_inside
+       ; return (res, tclvl') }
+
 getTcLevel :: TcM TcLevel
 getTcLevel = do { env <- getLclEnv
                 ; return (tcl_tclvl env) }
@@ -1508,8 +1551,8 @@ setTcLevel tclvl thing_inside
 
 isTouchableTcM :: TcTyVar -> TcM Bool
 isTouchableTcM tv
-  = do { env <- getLclEnv
-       ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
+  = do { lvl <- getTcLevel
+       ; return (isTouchableMetaTyVar lvl tv) }
 
 getLclTypeEnv :: TcM TcTypeEnv
 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
@@ -1578,7 +1621,7 @@ looks :-).
 
 However suppose we throw an exception inside an invocation of
 captureConstraints, and discard all the constraints. Some of those
-contraints might be "variable out of scope" Hole constraints, and that
+constraints might be "variable out of scope" Hole constraints, and that
 might have been the actual original cause of the exception!  For
 example (Trac #12529):
    f = p @ Int
@@ -1591,6 +1634,17 @@ Hence:
   - insolublesOnly in tryCaptureConstraints
   - emitConstraints in the Left case of captureConstraints
 
+Hover note that fresly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble.  The constraint solver does that.  So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+   t1 :: Int
+   t1 x = x   -- Manifestly wrong
+
+   foo = $(...raises exception...)
+We report the exception, but not the bug in t1.  Oh well.  Possible
+solution: make TcUnify.uType spot manifestly-insoluble constraints.
+
 
 ************************************************************************
 *                                                                      *
@@ -1721,7 +1775,7 @@ initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
         ; dflags <- getDynFlags
-        ; let mod = tcg_semantic_mod tcg_env
+        ; let !mod = tcg_semantic_mod tcg_env
               -- When we are instantiating a signature, we DEFINITELY
               -- do not want to knot tie.
               is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
@@ -1860,3 +1914,24 @@ up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
 discussion).  We don't currently know a general solution to this problem, but
 we can use uninterruptibleMask_ to avoid the situation.
 -}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+  extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+  extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+  extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+            => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+  env <- getGblEnv
+  let cc_st_ref = extractCostCentreState env
+  cc_st <- readTcRef cc_st_ref
+  let (idx, cc_st') = getCCIndex nm cc_st
+  writeTcRef cc_st_ref cc_st'
+  return idx
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 6383b57c28..147c16bba3 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -10,10 +10,10 @@ module.
 All the monads exported here are built on top of the same IOEnv monad. The
 monad functions like a Reader monad in the way it passes the environment
 around. This is done to allow the environment to be manipulated in a stack
-like fashion when entering expressions... ect.
+like fashion when entering expressions... etc.
 
 For state that is global and should be returned at the end (e.g not part
-of the stack mechanism), you should use an TcRef (= IORef) to store them.
+of the stack mechanism), you should use a TcRef (= IORef) to store them.
 -}
 
 {-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving,
@@ -38,7 +38,7 @@ module TcRnTypes(
         WhereFrom(..), mkModDeps, modDepsElts,
 
         -- Typechecker types
-        TcTypeEnv, TcIdBinderStack, TcIdBinder(..),
+        TcTypeEnv, TcBinderStack, TcBinder(..),
         TcTyThing(..), PromotionErr(..),
         IdBindingInfo(..), ClosedTypeId, RhsNames,
         IsGroupClosed(..),
@@ -46,7 +46,7 @@ module TcRnTypes(
         pprTcTyThingCategory, pprPECategory, CompleteMatch(..),
 
         -- Desugaring types
-        DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..),
+        DsM, DsLclEnv(..), DsGblEnv(..),
         DsMetaEnv, DsMetaVal(..), CompleteMatchMap,
         mkCompleteMatchMap, extendCompleteMatchMap,
 
@@ -64,52 +64,60 @@ module TcRnTypes(
         TcIdSigInst(..), TcPatSynInfo(..),
         isPartialSig, hasCompleteSig,
 
+        -- QCInst
+        QCInst(..), isPendingScInst,
+
         -- Canonical constraints
         Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
         isEmptyCts, isCTyEqCan, isCFunEqCan,
-        isPendingScDict, superClassesMightHelp,
+        isPendingScDict, superClassesMightHelp, getPendingWantedScs,
         isCDictCan_Maybe, isCFunEqCan_maybe,
-        isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
+        isCNonCanonical, isWantedCt, isDerivedCt,
         isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
         isUserTypeErrorCt, getUserTypeErrorMsg,
         ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
-        mkTcEqPredLikeEv,
+        ctEvId, mkTcEqPredLikeEv,
         mkNonCanonical, mkNonCanonicalCt, mkGivens,
+        mkIrredCt, mkInsolubleCt,
         ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
-        ctEvTerm, ctEvCoercion, ctEvId,
+        ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,
         tyCoVarsOfCt, tyCoVarsOfCts,
         tyCoVarsOfCtList, tyCoVarsOfCtsList,
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
-        andWC, unionsWC, mkSimpleWC, mkImplicWC,
-        addInsols, getInsolubles, insolublesOnly, addSimples, addImplics,
-        tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,
-        tyCoVarsOfWCList, trulyInsoluble,
-        isDroppableDerivedLoc, isDroppableDerivedCt, insolubleImplic,
+        isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC,
+        addInsols, insolublesOnly, addSimples, addImplics,
+        tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples,
+        tyCoVarsOfWCList, insolubleWantedCt, insolubleEqCt,
+        isDroppableCt, insolubleImplic,
         arisesFromGivens,
 
-        Implication(..), ImplicStatus(..), isInsolubleStatus, isSolvedStatus,
+        Implication(..), newImplication, implicLclEnv, implicDynFlags,
+        ImplicStatus(..), isInsolubleStatus, isSolvedStatus,
         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
         bumpSubGoalDepth, subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,
         ctLocTypeOrKind_maybe,
-        ctLocDepth, bumpCtLocDepth,
-        setCtLocOrigin, setCtLocEnv, setCtLocSpan,
+        ctLocDepth, bumpCtLocDepth, isGivenLoc,
+        setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,
         CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
-        ErrorThing(..), mkErrorThing, errorThingNumArgs_maybe,
+        isVisibleOrigin, toInvisibleOrigin,
         TypeOrKind(..), isTypeLevel, isKindLevel,
         pprCtOrigin, pprCtLoc,
         pushErrCtxt, pushErrCtxtSameOrigin,
 
+
         SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,
-        termEvidenceAllowed,
 
         CtEvidence(..), TcEvDest(..),
-        mkGivenLoc, mkKindLoc, toKindLoc,
+        mkKindLoc, toKindLoc, mkGivenLoc,
         isWanted, isGiven, isDerived, isGivenOrWDeriv,
         ctEvRole,
 
+        wrapType, wrapTypeWithImplication,
+        removeBindingShadowing,
+
         -- Constraint solver plugins
         TcPlugin(..), TcPluginResult(..), TcPluginSolver,
         TcPluginM, runTcPluginM, unsafeTcPluginTcM,
@@ -117,8 +125,8 @@ module TcRnTypes(
 
         CtFlavour(..), ShadowInfo(..), ctEvFlavour,
         CtFlavourRole, ctEvFlavourRole, ctFlavourRole,
-        eqCanRewriteFR, eqMayRewriteFR,
-        eqCanDischarge,
+        eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR,
+        eqCanDischargeFR,
         funEqCanDischarge, funEqCanDischargeF,
 
         -- Pretty printing
@@ -138,13 +146,16 @@ module TcRnTypes(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import CoreSyn
 import HscTypes
 import TcEvidence
 import Type
 import Class    ( Class )
-import TyCon    ( TyCon, tyConKind )
+import TyCon    ( TyCon, TyConFlavour, tyConKind )
+import TyCoRep  ( CoercionHole(..), coHoleCoVar )
 import Coercion ( Coercion, mkHoleCo )
 import ConLike  ( ConLike(..) )
 import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
@@ -181,11 +192,10 @@ import qualified GHC.LanguageExtensions as LangExt
 import Fingerprint
 import Util
 import PrelNames ( isUnboundName )
+import CostCentreState
 
 import Control.Monad (ap, liftM, msum)
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import Data.Set      ( Set )
 import qualified Data.Set as S
 
@@ -263,8 +273,9 @@ type TcM  = TcRn
 -- the lcl type).
 data Env gbl lcl
   = Env {
-        env_top  :: HscEnv,  -- Top-level stuff that never changes
+        env_top  :: !HscEnv, -- Top-level stuff that never changes
                              -- Includes all info about imported things
+                             -- BangPattern is to fix leak, see #15111
 
         env_us   :: {-# UNPACK #-} !(IORef UniqSupply),
                              -- Unique supply for local variables
@@ -354,25 +365,6 @@ a @UniqueSupply@ and some annotations, which
 presumably include source-file location information:
 -}
 
--- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
--- variables found in 'Data.Array.Parallel'.
---
-data PArrBuiltin
-        = PArrBuiltin
-        { lengthPVar         :: Var     -- ^ lengthP
-        , replicatePVar      :: Var     -- ^ replicateP
-        , singletonPVar      :: Var     -- ^ singletonP
-        , mapPVar            :: Var     -- ^ mapP
-        , filterPVar         :: Var     -- ^ filterP
-        , zipPVar            :: Var     -- ^ zipP
-        , crossMapPVar       :: Var     -- ^ crossMapP
-        , indexPVar          :: Var     -- ^ (!:)
-        , emptyPVar          :: Var     -- ^ emptyP
-        , appPVar            :: Var     -- ^ (+:+)
-        , enumFromToPVar     :: Var     -- ^ enumFromToP
-        , enumFromThenToPVar :: Var     -- ^ enumFromThenToP
-        }
-
 data DsGblEnv
         = DsGblEnv
         { ds_mod          :: Module             -- For SCC profiling
@@ -381,13 +373,10 @@ data DsGblEnv
         , ds_msgs    :: IORef Messages          -- Warning messages
         , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
                                                 -- possibly-imported things
-        , ds_dph_env :: GlobalRdrEnv            -- exported entities of 'Data.Array.Parallel.Prim'
-                                                -- iff '-fvectorise' flag was given as well as
-                                                -- exported entities of 'Data.Array.Parallel' iff
-                                                -- '-XParallelArrays' was given; otherwise, empty
-        , ds_parr_bi :: PArrBuiltin             -- desugarer names for '-XParallelArrays'
         , ds_complete_matches :: CompleteMatchMap
            -- Additional complete pattern matches
+        , ds_cc_st   :: IORef CostCentreState
+           -- Tracking indices for cost centre annotations
         }
 
 instance ContainsModule DsGblEnv where
@@ -396,9 +385,15 @@ instance ContainsModule DsGblEnv where
 data DsLclEnv = DsLclEnv {
         dsl_meta    :: DsMetaEnv,        -- Template Haskell bindings
         dsl_loc     :: RealSrcSpan,      -- To put in pattern-matching error msgs
-        dsl_dicts   :: Bag EvVar,        -- Constraints from GADT pattern-matching
-        dsl_tm_cs   :: Bag SimpleEq,
-        dsl_pm_iter :: IORef Int         -- no iterations for pmcheck
+
+        -- See Note [Note [Type and Term Equality Propagation] in Check.hs
+        -- These two fields are augmented as we walk inwards,
+        -- through each patttern match in turn
+        dsl_dicts   :: Bag EvVar,     -- Constraints from GADT pattern-matching
+        dsl_tm_cs   :: Bag SimpleEq,  -- Constraints form term-level pattern matching
+
+        dsl_pm_iter :: IORef Int  -- Number of iterations for pmcheck so far
+                                  -- We fail if this gets too big
      }
 
 -- Inside [| |] brackets, the desugarer looks
@@ -517,19 +512,14 @@ data TcGblEnv
                 -- bound in this module when dealing with hi-boot recursions
                 -- Updated at intervals (e.g. after dealing with types and classes)
 
-        tcg_inst_env     :: InstEnv,
+        tcg_inst_env     :: !InstEnv,
           -- ^ Instance envt for all /home-package/ modules;
           -- Includes the dfuns in tcg_insts
-        tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances
+          -- NB. BangPattern is to fix a leak, see #15111
+        tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances
+          -- NB. BangPattern is to fix a leak, see #15111
         tcg_ann_env      :: AnnEnv,     -- ^ And for annotations
 
-        -- | Family instances we have to check for consistency.
-        -- Invariant: each FamInst in the list's fi_fam matches the
-        -- key of the entry in the 'NameEnv'.  This gets consumed
-        -- by 'checkRecFamInstConsistency'.
-        -- See Note [Don't check hs-boot type family instances too early]
-        tcg_pending_fam_checks :: NameEnv [([FamInst], FamInstEnv)],
-
                 -- Now a bunch of things about this module that are simply
                 -- accumulated, but never consulted until the end.
                 -- Nevertheless, it's convenient to accumulate them along
@@ -616,10 +606,12 @@ data TcGblEnv
         -- The binds, rules and foreign-decl fields are collected
         -- initially in un-zonked form and are finally zonked in tcRnSrcDecls
 
-        tcg_rn_exports :: Maybe [Located (IE GhcRn)],
+        tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)],
                 -- Nothing <=> no explicit export list
                 -- Is always Nothing if we don't want to retain renamed
-                -- exports
+                -- exports.
+                -- If present contains each renamed export list item
+                -- together with its exported names.
 
         tcg_rn_imports :: [LImportDecl GhcRn],
                 -- Keep the renamed imports regardless.  They are not
@@ -634,7 +626,7 @@ data TcGblEnv
         tcg_th_topdecls :: TcRef [LHsDecl GhcPs],
         -- ^ Top-level declarations from addTopDecls
 
-        tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],
+        tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)],
         -- ^ Foreign files emitted from TH.
 
         tcg_th_topnames :: TcRef NameSet,
@@ -646,6 +638,9 @@ data TcGblEnv
         -- They are computations in the @TcM@ monad rather than @Q@ because we
         -- set them to use particular local environments.
 
+        tcg_th_coreplugins :: TcRef [String],
+        -- ^ Core plugins added by Template Haskell code.
+
         tcg_th_state :: TcRef (Map TypeRep Dynamic),
         tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
         -- ^ Template Haskell state
@@ -668,12 +663,12 @@ data TcGblEnv
         tcg_fam_insts :: [FamInst],          -- ...Family instances
         tcg_rules     :: [LRuleDecl GhcTc],  -- ...Rules
         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports
-        tcg_vects     :: [LVectDecl GhcTc],   -- ...Vectorisation declarations
         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms
 
         tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
-        tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
+        tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the
                                              --  prog uses hpc instrumentation.
+           -- NB. BangPattern is to fix a leak, see #15111
 
         tcg_self_boot :: SelfBootInfo,       -- ^ Whether this module has a
                                              -- corresponding hi-boot file
@@ -696,7 +691,10 @@ data TcGblEnv
         tcg_static_wc :: TcRef WantedConstraints,
           -- ^ Wanted constraints of static forms.
         -- See Note [Constraints in static forms].
-        tcg_complete_matches :: [CompleteMatch]
+        tcg_complete_matches :: [CompleteMatch],
+
+        -- ^ Tracking indices for cost centre annotations
+        tcg_cc_st   :: TcRef CostCentreState
     }
 
 -- NB: topModIdentity, not topModSemantic!
@@ -828,10 +826,8 @@ data TcLclEnv           -- Changes as we move inside an expression
         tcl_env  :: TcTypeEnv,    -- The local type environment:
                                   -- Ids and TyVars defined in this module
 
-        tcl_bndrs :: TcIdBinderStack,   -- Used for reporting relevant bindings
-
-        tcl_tidy :: TidyEnv,      -- Used for tidying types; contains all
-                                  -- in-scope type variables (but not term variables)
+        tcl_bndrs :: TcBinderStack,   -- Used for reporting relevant bindings,
+                                      -- and for tidying types
 
         tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars"
                         -- Namely, the in-scope TyVars bound in tcl_env,
@@ -885,34 +881,61 @@ type TcId        = Id
 type TcIdSet     = IdSet
 
 ---------------------------
--- The TcIdBinderStack
+-- The TcBinderStack
 ---------------------------
 
-type TcIdBinderStack = [TcIdBinder]
-   -- This is a stack of locally-bound ids, innermost on top
-   -- Used only in error reporting (relevantBindings in TcError)
+type TcBinderStack = [TcBinder]
+   -- This is a stack of locally-bound ids and tyvars,
+   --   innermost on top
+   -- Used only in error reporting (relevantBindings in TcError),
+   --   and in tidying
    -- We can't use the tcl_env type environment, because it doesn't
    --   keep track of the nesting order
 
-data TcIdBinder
+data TcBinder
   = TcIdBndr
        TcId
        TopLevelFlag    -- Tells whether the binding is syntactically top-level
                        -- (The monomorphic Ids for a recursive group count
                        --  as not-top-level for this purpose.)
+
   | TcIdBndr_ExpType  -- Variant that allows the type to be specified as
                       -- an ExpType
        Name
        ExpType
        TopLevelFlag
 
-instance Outputable TcIdBinder where
+  | TcTvBndr          -- e.g.   case x of P (y::a) -> blah
+       Name           -- We bind the lexical name "a" to the type of y,
+       TyVar          -- which might be an utterly different (perhaps
+                      -- existential) tyvar
+
+instance Outputable TcBinder where
    ppr (TcIdBndr id top_lvl)           = ppr id <> brackets (ppr top_lvl)
    ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl)
-
-instance HasOccName TcIdBinder where
-    occName (TcIdBndr id _) = (occName (idName id))
-    occName (TcIdBndr_ExpType name _ _) = (occName name)
+   ppr (TcTvBndr name tv)              = ppr name <+> ppr tv
+
+instance HasOccName TcBinder where
+    occName (TcIdBndr id _)             = occName (idName id)
+    occName (TcIdBndr_ExpType name _ _) = occName name
+    occName (TcTvBndr name _)           = occName name
+
+-- fixes #12177
+-- Builds up a list of bindings whose OccName has not been seen before
+-- i.e., If    ys  = removeBindingShadowing xs
+-- then
+--  - ys is obtained from xs by deleting some elements
+--  - ys has no duplicate OccNames
+--  - The first duplicated OccName in xs is retained in ys
+-- Overloaded so that it can be used for both GlobalRdrElt in typed-hole
+-- substitutions and TcBinder when looking for relevant bindings.
+removeBindingShadowing :: HasOccName a => [a] -> [a]
+removeBindingShadowing bindings = reverse $ fst $ foldl
+    (\(bindingAcc, seenNames) binding ->
+    if occName binding `elemOccSet` seenNames -- if we've seen it
+        then (bindingAcc, seenNames)              -- skip it
+        else (binding:bindingAcc, extendOccSet seenNames (occName binding)))
+    ([], emptyOccSet) bindings
 
 ---------------------------
 -- Template Haskell stages and levels
@@ -1079,15 +1102,20 @@ data PromotionErr
   | FamDataConPE     -- Data constructor for a data family
                      -- See Note [AFamDataCon: not promoting data family constructors]
                      -- in TcEnv.
+  | ConstrainedDataConPE PredType
+                     -- Data constructor with a non-equality context
+                     -- See Note [Don't promote data constructors with
+                     --           non-equality contexts] in TcHsType
   | PatSynPE         -- Pattern synonyms
                      -- See Note [Don't promote pattern synonyms] in TcEnv
 
+  | PatSynExPE       -- Pattern synonym existential type variable
+                     -- See Note [Pattern synonym existentials do not scope] in TcPatSyn
+
   | RecDataConPE     -- Data constructor in a recursive loop
-                     -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls
+                     -- See Note [Recursion and promoting data constructors] in TcTyClsDecls
   | NoDataKindsTC    -- -XDataKinds not enabled (for a tycon)
   | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)
-  | NoTypeInTypeTC   -- -XTypeInType not enabled (for a tycon)
-  | NoTypeInTypeDC   -- -XTypeInType not enabled (for a datacon)
 
 instance Outputable TcTyThing where     -- Debugging only
    ppr (AGlobal g)      = ppr g
@@ -1096,6 +1124,7 @@ instance Outputable TcTyThing where     -- Debugging only
                                  <> ppr (varType (tct_id elt)) <> comma
                                  <+> ppr (tct_info elt))
    ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv
+                            <+> dcolon <+> ppr (varType tv)
    ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)
    ppr (APromotionErr err) = text "APromotionErr" <+> ppr err
 
@@ -1158,8 +1187,8 @@ ClosedLet means that
    - For the ClosedTypeId field see Note [Bindings with closed types]
 
 For (static e) to be valid, we need for every 'x' free in 'e',
-x's binding must be floatable to top level.  Specifically:
-   * x's RhsNames must be non-empty
+that x's binding is floatable to the top level.  Specifically:
+   * x's RhsNames must be empty
    * x's type has no free variables
 See Note [Grand plan for static forms] in StaticPtrTable.hs.
 This test is made in TcExpr.checkClosedInStaticForm.
@@ -1184,7 +1213,7 @@ Here's the invariant:
    Specifically,
        a) The Id's acutal type is closed (has no free tyvars)
        b) Either the Id has a (closed) user-supplied type signature
-          or all its free varaibles are Global/ClosedLet
+          or all its free variables are Global/ClosedLet
              or NonClosedLet with ClosedTypeId=True.
           In particular, none are NotLetBound.
 
@@ -1231,15 +1260,16 @@ instance Outputable IdBindingInfo where
     text "TopLevelLet" <+> ppr fvs <+> ppr closed_type
 
 instance Outputable PromotionErr where
-  ppr ClassPE        = text "ClassPE"
-  ppr TyConPE        = text "TyConPE"
-  ppr PatSynPE       = text "PatSynPE"
-  ppr FamDataConPE   = text "FamDataConPE"
-  ppr RecDataConPE   = text "RecDataConPE"
-  ppr NoDataKindsTC  = text "NoDataKindsTC"
-  ppr NoDataKindsDC  = text "NoDataKindsDC"
-  ppr NoTypeInTypeTC = text "NoTypeInTypeTC"
-  ppr NoTypeInTypeDC = text "NoTypeInTypeDC"
+  ppr ClassPE                     = text "ClassPE"
+  ppr TyConPE                     = text "TyConPE"
+  ppr PatSynPE                    = text "PatSynPE"
+  ppr PatSynExPE                  = text "PatSynExPE"
+  ppr FamDataConPE                = text "FamDataConPE"
+  ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE"
+                                      <+> parens (ppr pred)
+  ppr RecDataConPE                = text "RecDataConPE"
+  ppr NoDataKindsTC               = text "NoDataKindsTC"
+  ppr NoDataKindsDC               = text "NoDataKindsDC"
 
 pprTcTyThingCategory :: TcTyThing -> SDoc
 pprTcTyThingCategory (AGlobal thing)    = pprTyThingCategory thing
@@ -1249,15 +1279,15 @@ pprTcTyThingCategory (ATcTyCon {})     = text "Local tycon"
 pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
 
 pprPECategory :: PromotionErr -> SDoc
-pprPECategory ClassPE        = text "Class"
-pprPECategory TyConPE        = text "Type constructor"
-pprPECategory PatSynPE       = text "Pattern synonym"
-pprPECategory FamDataConPE   = text "Data constructor"
-pprPECategory RecDataConPE   = text "Data constructor"
-pprPECategory NoDataKindsTC  = text "Type constructor"
-pprPECategory NoDataKindsDC  = text "Data constructor"
-pprPECategory NoTypeInTypeTC = text "Type constructor"
-pprPECategory NoTypeInTypeDC = text "Data constructor"
+pprPECategory ClassPE                = text "Class"
+pprPECategory TyConPE                = text "Type constructor"
+pprPECategory PatSynPE               = text "Pattern synonym"
+pprPECategory PatSynExPE             = text "Pattern synonym existential"
+pprPECategory FamDataConPE           = text "Data constructor"
+pprPECategory ConstrainedDataConPE{} = text "Data constructor"
+pprPECategory RecDataConPE           = text "Data constructor"
+pprPECategory NoDataKindsTC          = text "Type constructor"
+pprPECategory NoDataKindsDC          = text "Data constructor"
 
 {-
 ************************************************************************
@@ -1336,7 +1366,7 @@ data ImportAvails
 
 mkModDeps :: [(ModuleName, IsBootInterface)]
           -> ModuleNameEnv (ModuleName, IsBootInterface)
-mkModDeps deps = foldl add emptyUFM deps
+mkModDeps deps = foldl' add emptyUFM deps
                where
                  add env elt@(m,_) = addToUFM env m elt
 
@@ -1379,10 +1409,13 @@ plusImportAvails
                    imp_orphs         = orphs1 `unionLists` orphs2,
                    imp_finsts        = finsts1 `unionLists` finsts2 }
   where
-    plus_mod_dep (m1, boot1) (m2, boot2)
-        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-                -- Check mod-names match
-          (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
+    plus_mod_dep r1@(m1, boot1) r2@(m2, boot2)
+      | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
+        boot1 = r2
+      | otherwise = r1
+      -- If either side can "see" a non-hi-boot interface, use that
+      -- Reusing existing tuples saves 10% of allocations on test
+      -- perf/compiler/MultiLayerModules
 
 {-
 ************************************************************************
@@ -1467,7 +1500,7 @@ data TcIdSigInst
   = TISI { sig_inst_sig :: TcIdSigInfo
 
          , sig_inst_skols :: [(Name, TcTyVar)]
-               -- Instantiated type and kind variables, SigTvs
+               -- Instantiated type and kind variables, TyVarTvs
                -- The Name is the Name that the renamer chose;
                --   but the TcTyVar may come from instantiating
                --   the type and hence have a different unique.
@@ -1489,8 +1522,11 @@ data TcIdSigInst
                -- wildcards scope over the binding, and hence their
                -- Names may appear in type signatures in the binding
 
-         , sig_inst_wcx   :: Maybe TcTyVar
+         , sig_inst_wcx   :: Maybe TcType
                -- Extra-constraints wildcard to fill in, if any
+               -- If this exists, it is surely of the form (meta_tv |> co)
+               -- (where the co might be reflexive). This is filled in
+               -- only from the return value of TcHsType.tcWildCardOcc
          }
 
 {- Note [sig_inst_tau may be polymorphic]
@@ -1602,13 +1638,20 @@ data Ct
                            --              superclasses as Givens
     }
 
-  | CIrredEvCan {  -- These stand for yet-unusable predicates
-      cc_ev :: CtEvidence   -- See Note [Ct/evidence invariant]
-        -- The ctev_pred of the evidence is
-        -- of form   (tv xi1 xi2 ... xin)
+  | CIrredCan {  -- These stand for yet-unusable predicates
+      cc_ev    :: CtEvidence,   -- See Note [Ct/evidence invariant]
+      cc_insol :: Bool   -- True  <=> definitely an error, can never be solved
+                         -- False <=> might be soluble
+
+        -- For the might-be-soluble case, the ctev_pred of the evidence is
+        -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head
         --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant fails
         --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails
-        -- See Note [CIrredEvCan constraints]
+        -- See Note [CIrredCan constraints]
+
+        -- The definitely-insoluble case is for things like
+        --    Int ~ Bool      tycons don't match
+        --    a ~ [a]         occurs check
     }
 
   | CTyEqCan {  -- tv ~ rhs
@@ -1617,7 +1660,7 @@ data Ct
        --   * tv not in tvs(rhs)   (occurs check)
        --   * If tv is a TauTv, then rhs has no foralls
        --       (this avoids substituting a forall for the tyvar in other types)
-       --   * typeKind ty `tcEqKind` typeKind tv
+       --   * typeKind ty `tcEqKind` typeKind tv; Note [Ct kind invariant]
        --   * rhs may have at most one top-level cast
        --   * rhs (perhaps under the one cast) is not necessarily function-free,
        --       but it has no top-level function.
@@ -1640,7 +1683,7 @@ data Ct
   | CFunEqCan {  -- F xis ~ fsk
        -- Invariants:
        --   * isTypeFamilyTyCon cc_fun
-       --   * typeKind (F xis) = tyVarKind fsk
+       --   * typeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant]
        --   * always Nominal role
       cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]
       cc_fun    :: TyCon,       -- A type function
@@ -1650,8 +1693,8 @@ data Ct
         --    *never* over-saturated (because if so
         --    we should have decomposed)
 
-      cc_fsk    :: TcTyVar  -- [Given]  always a FlatSkolTv
-                            -- [Wanted] always a FlatMetaTv
+      cc_fsk    :: TcTyVar  -- [G]  always a FlatSkolTv
+                            -- [W], [WD], or [D] always a FlatMetaTv
         -- See Note [The flattening story] in TcFlatten
     }
 
@@ -1666,6 +1709,26 @@ data Ct
       cc_hole :: Hole
     }
 
+  | CQuantCan QCInst       -- A quantified constraint
+      -- NB: I expect to make more of the cases in Ct
+      --     look like this, with the payload in an
+      --     auxiliary type
+
+------------
+data QCInst  -- A much simplified version of ClsInst
+             -- See Note [Quantified constraints] in TcCanonical
+  = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty
+                                 -- Always Given
+        , qci_tvs  :: [TcTyVar]  -- The tvs
+        , qci_pred :: TcPredType -- The ty
+        , qci_pend_sc :: Bool    -- Same as cc_pend_sc flag in CDictCan
+                                 -- Invariant: True => qci_pred is a ClassPred
+    }
+
+instance Outputable QCInst where
+  ppr (QCI { qci_ev = ev }) = ppr ev
+
+------------
 -- | An expression or type hole
 data Hole = ExprHole UnboundVar
             -- ^ Either an out-of-scope variable or a "true" hole in an
@@ -1673,6 +1736,10 @@ data Hole = ExprHole UnboundVar
           | TypeHole OccName
             -- ^ A hole in a type (PartialTypeSignatures)
 
+instance Outputable Hole where
+  ppr (ExprHole ub)  = ppr ub
+  ppr (TypeHole occ) = text "TypeHole" <> parens (ppr occ)
+
 holeOcc :: Hole -> OccName
 holeOcc (ExprHole uv)  = unboundVarOcc uv
 holeOcc (TypeHole occ) = occ
@@ -1689,9 +1756,9 @@ distinguished by cc_hole:
     e.g.   f :: _ -> _
            f x = [x,True]
 
-Note [CIrredEvCan constraints]
+Note [CIrredCan constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-CIrredEvCan constraints are used for constraints that are "stuck"
+CIrredCan constraints are used for constraints that are "stuck"
    - we can't solve them (yet)
    - we can't use them to solve other constraints
    - but they may become soluble if we substitute for some
@@ -1702,7 +1769,7 @@ Example 1:  (c Int), where c :: * -> Constraint.  We can't do anything
 
 Example 2:  a ~ b, where a :: *, b :: k, where k is a kind variable
             We don't want to use this to substitute 'b' for 'a', in case
-            'k' is subequently unifed with (say) *->*, because then
+            'k' is subsequently unifed with (say) *->*, because then
             we'd have ill-kinded types floating about.  Rather we want
             to defer using the equality altogether until 'k' get resolved.
 
@@ -1717,6 +1784,14 @@ built (in TcCanonical).
 In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in
 the evidence may *not* be fully zonked; we are careful not to look at it
 during constraint solving. See Note [Evidence field of CtEvidence].
+
+Note [Ct kind invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~
+CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind
+of the rhs. This is necessary because both constraints are used for substitutions
+during solving. If the kinds differed, then the substitution would take a well-kinded
+type to an ill-kinded one.
+
 -}
 
 mkNonCanonical :: CtEvidence -> Ct
@@ -1725,6 +1800,12 @@ mkNonCanonical ev = CNonCanonical { cc_ev = ev }
 mkNonCanonicalCt :: Ct -> Ct
 mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct }
 
+mkIrredCt :: CtEvidence -> Ct
+mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False }
+
+mkInsolubleCt :: CtEvidence -> Ct
+mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True }
+
 mkGivens :: CtLoc -> [EvId] -> [Ct]
 mkGivens loc ev_ids
   = map mk ev_ids
@@ -1734,7 +1815,8 @@ mkGivens loc ev_ids
                                        , ctev_loc = loc })
 
 ctEvidence :: Ct -> CtEvidence
-ctEvidence = cc_ev
+ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
+ctEvidence ct = cc_ev ct
 
 ctLoc :: Ct -> CtLoc
 ctLoc = ctEvLoc . ctEvidence
@@ -1747,7 +1829,11 @@ ctOrigin = ctLocOrigin . ctLoc
 
 ctPred :: Ct -> PredType
 -- See Note [Ct/evidence invariant]
-ctPred ct = ctEvPred (cc_ev ct)
+ctPred ct = ctEvPred (ctEvidence ct)
+
+ctEvId :: Ct -> EvVar
+-- The evidence Id for this Ct
+ctEvId ct = ctEvEvId (ctEvidence ct)
 
 -- | Makes a new equality predicate with the same role as the given
 -- evidence.
@@ -1768,7 +1854,7 @@ ctEqRel :: Ct -> EqRel
 ctEqRel = ctEvEqRel . ctEvidence
 
 instance Outputable Ct where
-  ppr ct = ppr (cc_ev ct) <+> parens pp_sort
+  ppr ct = ppr (ctEvidence ct) <+> parens pp_sort
     where
       pp_sort = case ct of
          CTyEqCan {}      -> text "CTyEqCan"
@@ -1777,8 +1863,13 @@ instance Outputable Ct where
          CDictCan { cc_pend_sc = pend_sc }
             | pend_sc   -> text "CDictCan(psc)"
             | otherwise -> text "CDictCan"
-         CIrredEvCan {}   -> text "CIrredEvCan"
-         CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr (holeOcc hole)
+         CIrredCan { cc_insol = insol }
+            | insol     -> text "CIrredCan(insol)"
+            | otherwise -> text "CIrredCan(sol)"
+         CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr hole
+         CQuantCan (QCI { qci_pend_sc = pend_sc })
+            | pend_sc   -> text "CQuantCan(psc)"
+            | otherwise -> text "CQuantCan"
 
 {-
 ************************************************************************
@@ -1809,9 +1900,7 @@ tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk })
   = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk
                        `unionFV` tyCoFVsOfType (tyVarKind fsk)
 tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys
-tyCoFVsOfCt (CIrredEvCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)
-tyCoFVsOfCt (CHoleCan { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)
-tyCoFVsOfCt (CNonCanonical { cc_ev = ev }) = tyCoFVsOfType (ctEvPred ev)
+tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct)
 
 -- | Returns free variables of a bag of constraints as a non-deterministic
 -- set. See Note [Deterministic FV] in FV.
@@ -1844,10 +1933,9 @@ tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC
 -- computation. See Note [Deterministic FV] in FV.
 tyCoFVsOfWC :: WantedConstraints -> FV
 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
-tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
+tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic })
   = tyCoFVsOfCts simple `unionFV`
-    tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`
-    tyCoFVsOfCts insol
+    tyCoFVsOfBag tyCoFVsOfImplic implic
 
 -- | Returns free variables of Implication as a composable FV computation.
 -- See Note [Deterministic FV] in FV.
@@ -1862,6 +1950,13 @@ tyCoFVsOfImplic (Implic { ic_skols = skols
 tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV
 tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV
 
+---------------------------
+dropDerivedWC :: WantedConstraints -> WantedConstraints
+-- See Note [Dropping derived constraints]
+dropDerivedWC wc@(WC { wc_simple = simples })
+  = wc { wc_simple = dropDerivedSimples simples }
+    -- The wc_impl implications are already (recursively) filtered
+
 --------------------------
 dropDerivedSimples :: Cts -> Cts
 -- Drop all Derived constraints, but make [W] back into [WD],
@@ -1875,8 +1970,8 @@ dropDerivedCt ct
   = case ctEvFlavour ev of
       Wanted WOnly -> Just (ct' { cc_ev = ev_wd })
       Wanted _     -> Just ct'
-      _            -> ASSERT( isDerivedCt ct ) Nothing
-                      -- simples are all Wanted or Derived
+      _ | isDroppableCt ct -> Nothing
+        | otherwise        -> Just ct
   where
     ev    = ctEvidence ct
     ev_wd = ev { ctev_nosh = WDeriv }
@@ -1892,33 +1987,41 @@ we might miss some fundeps.  Trac #13662 showed this up.
 See Note [The superclass story] in TcCanonical.
 -}
 
-
-dropDerivedInsols :: Cts -> Cts
--- See Note [Dropping derived constraints]
-dropDerivedInsols insols
-  = filterBag (not . isDroppableDerivedCt) insols
-              -- insols can include Given
-
-isDroppableDerivedCt :: Ct -> Bool
-isDroppableDerivedCt ct
-  | isDerivedCt ct = isDroppableDerivedLoc (ctLoc ct)
-  | otherwise      = False
-
-isDroppableDerivedLoc :: CtLoc -> Bool
--- See Note [Dropping derived constraints]
-isDroppableDerivedLoc loc
-  = case ctLocOrigin loc of
-      HoleOrigin {}    -> False
-      KindEqOrigin {}  -> False
-      GivenOrigin {}   -> False
-
-      -- See Note [Dropping derived constraints]
-      -- For fundeps, drop wanted/wanted interactions
-      FunDepOrigin2 {} -> False
-      FunDepOrigin1 _ loc1 _ loc2
-        | isGivenLoc loc1 || isGivenLoc loc2 -> False
-        | otherwise                          -> True
-      _ -> True
+isDroppableCt :: Ct -> Bool
+isDroppableCt ct
+  = isDerived ev && not keep_deriv
+    -- Drop only derived constraints, and then only if they
+    -- obey Note [Dropping derived constraints]
+  where
+    ev   = ctEvidence ct
+    loc  = ctEvLoc ev
+    orig = ctLocOrigin loc
+
+    keep_deriv
+      = case ct of
+          CHoleCan {} -> True
+          CIrredCan { cc_insol = insoluble }
+                      -> keep_eq insoluble
+          _           -> keep_eq False
+
+    keep_eq definitely_insoluble
+       | isGivenOrigin orig    -- Arising only from givens
+       = definitely_insoluble  -- Keep only definitely insoluble
+       | otherwise
+       = case orig of
+           KindEqOrigin {} -> True    -- See Note [Dropping derived constraints]
+
+           -- See Note [Dropping derived constraints]
+           -- For fundeps, drop wanted/wanted interactions
+           FunDepOrigin2 {} -> True   -- Top-level/Wanted
+           FunDepOrigin1 _ loc1 _ loc2
+             | g1 || g2  -> True  -- Given/Wanted errors: keep all
+             | otherwise -> False -- Wanted/Wanted errors: discard
+             where
+               g1 = isGivenLoc loc1
+               g2 = isGivenLoc loc2
+
+           _ -> False
 
 arisesFromGivens :: Ct -> Bool
 arisesFromGivens ct
@@ -1941,30 +2044,46 @@ isGivenOrigin _                         = False
 In general we discard derived constraints at the end of constraint solving;
 see dropDerivedWC.  For example
 
- * If we have an unsolved [W] (Ord a), we don't want to complain about
-   an unsolved [D] (Eq a) as well.
+ * Superclasses: if we have an unsolved [W] (Ord a), we don't want to
+   complain about an unsolved [D] (Eq a) as well.
 
  * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate
-   [D] Int ~ Bool, and we don't want to report that because it's incomprehensible.
-   That is why we don't rewrite wanteds with wanteds!
+   [D] Int ~ Bool, and we don't want to report that because it's
+   incomprehensible. That is why we don't rewrite wanteds with wanteds!
 
-But (tiresomely) we do keep *some* Derived insolubles:
+But (tiresomely) we do keep *some* Derived constraints:
 
  * Type holes are derived constraints, because they have no evidence
    and we want to keep them, so we get the error report
 
- * Insoluble derived equalities (e.g. [D] Int ~ Bool) may arise from
-   functional dependency interactions:
-      - Given or Wanted interacting with an instance declaration (FunDepOrigin2)
-      - Given/Given interactions (FunDepOrigin1); this reflects unreachable code
+ * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with
+   KindEqOrigin, may arise from a type equality a ~ Int#, say.  See
+   Note [Equalities with incompatible kinds] in TcCanonical.
+   These need to be kept because the kind equalities might have different
+   source locations and hence different error messages.
+   E.g., test case dependent/should_fail/T11471
+
+ * We keep most derived equalities arising from functional dependencies
+      - Given/Given interactions (subset of FunDepOrigin1):
+        The definitely-insoluble ones reflect unreachable code.
+
+        Others not-definitely-insoluble ones like [D] a ~ Int do not
+        reflect unreachable code; indeed if fundeps generated proofs, it'd
+        be a useful equality.  See Trac #14763.   So we discard them.
+
+      - Given/Wanted interacGiven or Wanted interacting with an
+        instance declaration (FunDepOrigin2)
+
       - Given/Wanted interactions (FunDepOrigin1); see Trac #9612
 
-   But for Wanted/Wanted interactions we do /not/ want to report an
-   error (Trac #13506).  Consider [W] C Int Int, [W] C Int Bool, with
-   a fundep on class C.  We don't want to report an insoluble Int~Bool;
-   c.f. "wanteds do not rewrite wanteds".
+      - But for Wanted/Wanted interactions we do /not/ want to report an
+        error (Trac #13506).  Consider [W] C Int Int, [W] C Int Bool, with
+        a fundep on class C.  We don't want to report an insoluble Int~Bool;
+        c.f. "wanteds do not rewrite wanteds".
+
+To distinguish these cases we use the CtOrigin.
 
-Moreover, we keep *all* derived insolubles under some circumstances:
+NB: we keep *all* derived insolubles under some circumstances:
 
   * They are looked at by simplifyInfer, to decide whether to
     generalise.  Example: [W] a ~ Int, [W] a ~ Bool
@@ -1972,8 +2091,6 @@ Moreover, we keep *all* derived insolubles under some circumstances:
     and we want simplifyInfer to see that, even though we don't
     ultimately want to generate an (inexplicable) error message from it
 
-To distinguish these cases we use the CtOrigin.
-
 
 ************************************************************************
 *                                                                      *
@@ -1984,13 +2101,13 @@ To distinguish these cases we use the CtOrigin.
 -}
 
 isWantedCt :: Ct -> Bool
-isWantedCt = isWanted . cc_ev
+isWantedCt = isWanted . ctEvidence
 
 isGivenCt :: Ct -> Bool
-isGivenCt = isGiven . cc_ev
+isGivenCt = isGiven . ctEvidence
 
 isDerivedCt :: Ct -> Bool
-isDerivedCt = isDerived . cc_ev
+isDerivedCt = isDerived . ctEvidence
 
 isCTyEqCan :: Ct -> Bool
 isCTyEqCan (CTyEqCan {})  = True
@@ -2001,10 +2118,6 @@ isCDictCan_Maybe :: Ct -> Maybe Class
 isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
 isCDictCan_Maybe _              = Nothing
 
-isCIrredEvCan :: Ct -> Bool
-isCIrredEvCan (CIrredEvCan {}) = True
-isCIrredEvCan _                = False
-
 isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])
 isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)
 isCFunEqCan_maybe _ = Nothing
@@ -2089,27 +2202,49 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
                          _      -> False
 
 isPendingScDict :: Ct -> Maybe Ct
--- Says whether cc_pend_sc is True, AND if so flips the flag
+-- Says whether this is a CDictCan with cc_pend_sc is True,
+-- AND if so flips the flag
 isPendingScDict ct@(CDictCan { cc_pend_sc = True })
                   = Just (ct { cc_pend_sc = False })
 isPendingScDict _ = Nothing
 
+isPendingScInst :: QCInst -> Maybe QCInst
+-- Same as isPrendinScDict, but for QCInsts
+isPendingScInst qci@(QCI { qci_pend_sc = True })
+                  = Just (qci { qci_pend_sc = False })
+isPendingScInst _ = Nothing
+
 setPendingScDict :: Ct -> Ct
 -- Set the cc_pend_sc flag to True
 setPendingScDict ct@(CDictCan { cc_pend_sc = False })
                     = ct { cc_pend_sc = True }
 setPendingScDict ct = ct
 
-superClassesMightHelp :: Ct -> Bool
+superClassesMightHelp :: WantedConstraints -> Bool
 -- ^ True if taking superclasses of givens, or of wanteds (to perhaps
 -- expose more equalities or functional dependencies) might help to
 -- solve this constraint.  See Note [When superclasses help]
-superClassesMightHelp ct
-  = isWantedCt ct && not (is_ip ct)
+superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })
+  = anyBag might_help_ct simples || anyBag might_help_implic implics
   where
+    might_help_implic ic
+       | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic)
+       | otherwise                   = False
+
+    might_help_ct ct = isWantedCt ct && not (is_ip ct)
+
     is_ip (CDictCan { cc_class = cls }) = isIPClass cls
     is_ip _                             = False
 
+getPendingWantedScs :: Cts -> ([Ct], Cts)
+getPendingWantedScs simples
+  = mapAccumBagL get [] simples
+  where
+    get acc ct | Just ct' <- isPendingScDict ct
+               = (ct':acc, ct')
+               | otherwise
+               = (acc,     ct)
+
 {- Note [When superclasses help]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 First read Note [The superclass story] in TcCanonical.
@@ -2120,6 +2255,11 @@ might actually help. The function superClassesMightHelp tells if
 doing this superclass expansion might help solve this constraint.
 Note that
 
+  * We look inside implications; maybe it'll help to expand the Givens
+    at level 2 to help solve an unsolved Wanted buried inside an
+    implication.  E.g.
+        forall a. Ord a => forall b. [W] Eq a
+
   * Superclasses help only for Wanted constraints.  Derived constraints
     are not really "unsolved" and we certainly don't want them to
     trigger superclass expansion. This was a good part of the loop
@@ -2197,34 +2337,37 @@ v%************************************************************************
 data WantedConstraints
   = WC { wc_simple :: Cts              -- Unsolved constraints, all wanted
        , wc_impl   :: Bag Implication
-       , wc_insol  :: Cts              -- Insoluble constraints, can be
-                                       -- wanted, given, or derived
-                                       -- See Note [Insoluble constraints]
     }
 
 emptyWC :: WantedConstraints
-emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }
+emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag }
 
 mkSimpleWC :: [CtEvidence] -> WantedConstraints
 mkSimpleWC cts
   = WC { wc_simple = listToBag (map mkNonCanonical cts)
-       , wc_impl = emptyBag
-       , wc_insol = emptyBag }
+       , wc_impl = emptyBag }
 
 mkImplicWC :: Bag Implication -> WantedConstraints
 mkImplicWC implic
-  = WC { wc_simple = emptyBag, wc_impl = implic, wc_insol = emptyBag }
+  = WC { wc_simple = emptyBag, wc_impl = implic }
 
 isEmptyWC :: WantedConstraints -> Bool
-isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n })
-  = isEmptyBag f && isEmptyBag i && isEmptyBag n
+isEmptyWC (WC { wc_simple = f, wc_impl = i })
+  = isEmptyBag f && isEmptyBag i
+
+
+-- | Checks whether a the given wanted constraints are solved, i.e.
+-- that there are no simple constraints left and all the implications
+-- are solved.
+isSolvedWC :: WantedConstraints -> Bool
+isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl} =
+  isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl
 
 andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints
-andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 })
-      (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 })
+andWC (WC { wc_simple = f1, wc_impl = i1 })
+      (WC { wc_simple = f2, wc_impl = i2 })
   = WC { wc_simple = f1 `unionBags` f2
-       , wc_impl   = i1 `unionBags` i2
-       , wc_insol  = n1 `unionBags` n2 }
+       , wc_impl   = i1 `unionBags` i2 }
 
 unionsWC :: [WantedConstraints] -> WantedConstraints
 unionsWC = foldr andWC emptyWC
@@ -2239,58 +2382,64 @@ addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
 
 addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
 addInsols wc cts
-  = wc { wc_insol = wc_insol wc `unionBags` cts }
-
-getInsolubles :: WantedConstraints -> Cts
-getInsolubles = wc_insol
+  = wc { wc_simple = wc_simple wc `unionBags` cts }
 
 insolublesOnly :: WantedConstraints -> WantedConstraints
--- Keep only the insolubles
-insolublesOnly wc = wc { wc_simple = emptyBag, wc_impl = emptyBag }
-
-dropDerivedWC :: WantedConstraints -> WantedConstraints
--- See Note [Dropping derived constraints]
-dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
-  = wc { wc_simple = dropDerivedSimples simples
-       , wc_insol  = dropDerivedInsols insols }
-    -- The wc_impl implications are already (recursively) filtered
+-- Keep only the definitely-insoluble constraints
+insolublesOnly (WC { wc_simple = simples, wc_impl = implics })
+  = WC { wc_simple = filterBag insolubleWantedCt simples
+       , wc_impl   = mapBag implic_insols_only implics }
+  where
+    implic_insols_only implic
+      = implic { ic_wanted = insolublesOnly (ic_wanted implic) }
 
 isSolvedStatus :: ImplicStatus -> Bool
 isSolvedStatus (IC_Solved {}) = True
 isSolvedStatus _              = False
 
 isInsolubleStatus :: ImplicStatus -> Bool
-isInsolubleStatus IC_Insoluble = True
-isInsolubleStatus _            = False
+isInsolubleStatus IC_Insoluble    = True
+isInsolubleStatus IC_BadTelescope = True
+isInsolubleStatus _               = False
 
 insolubleImplic :: Implication -> Bool
 insolubleImplic ic = isInsolubleStatus (ic_status ic)
 
 insolubleWC :: WantedConstraints -> Bool
-insolubleWC (WC { wc_impl = implics, wc_insol = insols })
-  =  anyBag trulyInsoluble insols
+insolubleWC (WC { wc_impl = implics, wc_simple = simples })
+  =  anyBag insolubleWantedCt simples
   || anyBag insolubleImplic implics
 
-trulyInsoluble :: Ct -> Bool
--- Constraints in the wc_insol set which ARE NOT
--- treated as truly insoluble:
---   a) type holes, arising from PartialTypeSignatures,
---   b) "true" expression holes arising from TypedHoles
+insolubleWantedCt :: Ct -> Bool
+-- Definitely insoluble, in particular /excluding/ type-hole constraints
+insolubleWantedCt ct
+  | isGivenCt ct     = False              -- See Note [Given insolubles]
+  | isHoleCt ct      = isOutOfScopeCt ct  -- See Note [Insoluble holes]
+  | insolubleEqCt ct = True
+  | otherwise        = False
+
+insolubleEqCt :: Ct -> Bool
+-- Returns True of /equality/ constraints
+-- that are /definitely/ insoluble
+-- It won't detect some definite errors like
+--       F a ~ T (F a)
+-- where F is a type family, which actually has an occurs check
 --
--- An "expression hole" or "type hole" constraint isn't really an error
--- at all; it's a report saying "_ :: Int" here.  But an out-of-scope
--- variable masquerading as expression holes IS treated as truly
--- insoluble, so that it trumps other errors during error reporting.
--- Yuk!
-trulyInsoluble insol
-  | isHoleCt insol = isOutOfScopeCt insol
-  | otherwise      = True
+-- The function is tuned for application /after/ constraint solving
+--       i.e. assuming canonicalisation has been done
+-- E.g.  It'll reply True  for     a ~ [a]
+--               but False for   [a] ~ a
+-- and
+--                   True for  Int ~ F a Int
+--               but False for  Maybe Int ~ F a Int Int
+--               (where F is an arity-1 type function)
+insolubleEqCt (CIrredCan { cc_insol = insol }) = insol
+insolubleEqCt _                                = False
 
 instance Outputable WantedConstraints where
-  ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n})
+  ppr (WC {wc_simple = s, wc_impl = i})
    = text "WC" <+> braces (vcat
         [ ppr_bag (text "wc_simple") s
-        , ppr_bag (text "wc_insol") n
         , ppr_bag (text "wc_impl") i ])
 
 ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc
@@ -2299,7 +2448,43 @@ ppr_bag doc bag
  | otherwise      = hang (doc <+> equals)
                        2 (foldrBag (($$) . ppr) empty bag)
 
-{-
+{- Note [Given insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14325, comment:)
+    class (a~b) => C a b
+
+    foo :: C a c => a -> c
+    foo x = x
+
+    hm3 :: C (f b) b => b -> f b
+    hm3 x = foo x
+
+In the RHS of hm3, from the [G] C (f b) b we get the insoluble
+[G] f b ~# b.  Then we also get an unsolved [W] C b (f b).
+Residual implication looks like
+    forall b. C (f b) b => [G] f b ~# b
+                           [W] C f (f b)
+
+We do /not/ want to set the implication status to IC_Insoluble,
+because that'll suppress reports of [W] C b (f b).  But we
+may not report the insoluble [G] f b ~# b either (see Note [Given errors]
+in TcErrors), so we may fail to report anything at all!  Yikes.
+
+Bottom line: insolubleWC (called in TcSimplify.setImplicationStatus)
+             should ignore givens even if they are insoluble.
+
+Note [Insoluble holes]
+~~~~~~~~~~~~~~~~~~~~~~
+Hole constraints that ARE NOT treated as truly insoluble:
+  a) type holes, arising from PartialTypeSignatures,
+  b) "true" expression holes arising from TypedHoles
+
+An "expression hole" or "type hole" constraint isn't really an error
+at all; it's a report saying "_ :: Int" here.  But an out-of-scope
+variable masquerading as expression holes IS treated as truly
+insoluble, so that it trumps other errors during error reporting.
+Yuk!
+
 ************************************************************************
 *                                                                      *
                 Implication constraints
@@ -2308,13 +2493,20 @@ ppr_bag doc bag
 -}
 
 data Implication
-  = Implic {
+  = Implic {   -- Invariants for a tree of implications:
+               -- see TcType Note [TcLevel and untouchable type variables]
+
       ic_tclvl :: TcLevel,       -- TcLevel of unification variables
                                  -- allocated /inside/ this implication
 
       ic_skols :: [TcTyVar],     -- Introduced skolems
       ic_info  :: SkolemInfo,    -- See Note [Skolems in an implication]
                                  -- See Note [Shadowing in a constraint]
+      ic_telescope :: Maybe SDoc,  -- User-written telescope, if there is one
+                                   -- The list of skolems is order-checked
+                                   -- if and only if this is a Just.
+                                   -- See Note [Keeping scoped variables in order: Explicit]
+                                   -- in TcHsType
 
       ic_given  :: [EvVar],      -- Given evidence variables
                                  --   (order does not matter)
@@ -2323,37 +2515,91 @@ data Implication
       ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure
                                  -- False <=> ic_givens might have equalities
 
-      ic_env   :: TcLclEnv,      -- Gives the source location and error context
-                                 -- for the implication, and hence for all the
-                                 -- given evidence variables
-
-      ic_wanted :: WantedConstraints,  -- The wanted
+      ic_env   :: Env TcGblEnv TcLclEnv,
+                                 -- Records the Env at the time of creation.
+                                 --
+                                 -- This is primarly needed for the enclosed
+                                 -- TcLclEnv, which gives the source location
+                                 -- and error context for the implication, and
+                                 -- hence for all the given evidence variables.
+                                 --
+                                 -- The enclosed DynFlags also influences error
+                                 -- reporting. See Note [Avoid
+                                 -- -Winaccessible-code when deriving] in
+                                 -- TcInstDcls.
+
+      ic_wanted :: WantedConstraints,  -- The wanteds
+                                       -- See Invariang (WantedInf) in TcType
 
       ic_binds  :: EvBindsVar,    -- Points to the place to fill in the
                                   -- abstraction and bindings.
 
-      ic_needed   :: VarSet,      -- Union of the ics_need fields of any /discarded/
-                                  -- solved implications in ic_wanted
+      -- The ic_need fields keep track of which Given evidence
+      -- is used by this implication or its children
+      -- NB: including stuff used by nested implications that have since
+      --     been discarded
+      ic_need_inner :: VarSet,    -- Includes all used Given evidence
+      ic_need_outer :: VarSet,    -- Includes only the free Given evidence
+                                  --  i.e. ic_need_inner after deleting
+                                  --       (a) givens (b) binders of ic_binds
 
       ic_status   :: ImplicStatus
     }
 
+-- | Create a new 'Implication' with as many sensible defaults for its fields
+-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do
+-- /not/ have sensible defaults, so they are initialized with lazy thunks that
+-- will 'panic' if forced, so one should take care to initialize these fields
+-- after creation.
+--
+-- This is monadic purely to look up the 'Env', which is used to initialize
+-- 'ic_env'.
+newImplication :: TcM Implication
+newImplication
+  = do env <- getEnv
+       pure $ Implic { -- These fields must be initialised
+                       ic_tclvl      = panic "newImplic:tclvl"
+                     , ic_binds      = panic "newImplic:binds"
+                     , ic_info       = panic "newImplic:info"
+
+                       -- The rest have sensible default values
+                     , ic_env        = env
+                     , ic_skols      = []
+                     , ic_telescope  = Nothing
+                     , ic_given      = []
+                     , ic_wanted     = emptyWC
+                     , ic_no_eqs     = False
+                     , ic_status     = IC_Unsolved
+                     , ic_need_inner = emptyVarSet
+                     , ic_need_outer = emptyVarSet }
+
+-- | Retrieve the enclosed 'TcLclEnv' from an 'Implication'.
+implicLclEnv :: Implication -> TcLclEnv
+implicLclEnv = env_lcl . ic_env
+
+-- | Retrieve the enclosed 'DynFlags' from an 'Implication'.
+implicDynFlags :: Implication -> DynFlags
+implicDynFlags = hsc_dflags . env_top . ic_env
+
 data ImplicStatus
   = IC_Solved     -- All wanteds in the tree are solved, all the way down
-       { ics_need :: VarSet     -- Evidence variables bound further out,
-                                -- but needed by this solved implication
-       , ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed
+       { ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed
          -- See Note [Tracking redundant constraints] in TcSimplify
 
   | IC_Insoluble  -- At least one insoluble constraint in the tree
 
+  | IC_BadTelescope  -- solved, but the skolems in the telescope are out of
+                     -- dependency order
+
   | IC_Unsolved   -- Neither of the above; might go either way
 
 instance Outputable Implication where
   ppr (Implic { ic_tclvl = tclvl, ic_skols = skols
               , ic_given = given, ic_no_eqs = no_eqs
               , ic_wanted = wanted, ic_status = status
-              , ic_binds = binds, ic_needed = needed , ic_info = info })
+              , ic_binds = binds
+              , ic_need_inner = need_in, ic_need_outer = need_out
+              , ic_info = info })
    = hang (text "Implic" <+> lbrace)
         2 (sep [ text "TcLevel =" <+> ppr tclvl
                , text "Skolems =" <+> pprTyVars skols
@@ -2362,16 +2608,16 @@ instance Outputable Implication where
                , hang (text "Given =")  2 (pprEvVars given)
                , hang (text "Wanted =") 2 (ppr wanted)
                , text "Binds =" <+> ppr binds
-               , text "Needed =" <+> ppr needed
+               , whenPprDebug (text "Needed inner =" <+> ppr need_in)
+               , whenPprDebug (text "Needed outer =" <+> ppr need_out)
                , pprSkolInfo info ] <+> rbrace)
 
 instance Outputable ImplicStatus where
-  ppr IC_Insoluble   = text "Insoluble"
-  ppr IC_Unsolved    = text "Unsolved"
-  ppr (IC_Solved { ics_need = vs, ics_dead = dead })
-    = text "Solved"
-      <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead
-                         , text "Needed =" <+> ppr vs ])
+  ppr IC_Insoluble    = text "Insoluble"
+  ppr IC_BadTelescope = text "Bad telescope"
+  ppr IC_Unsolved     = text "Unsolved"
+  ppr (IC_Solved { ics_dead = dead })
+    = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead))
 
 {-
 Note [Needed evidence variables]
@@ -2455,6 +2701,23 @@ pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
 pprEvVarWithType :: EvVar -> SDoc
 pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)
 
+
+
+-- | Wraps the given type with the constraints (via ic_given) in the given
+-- implication, according to the variables mentioned (via ic_skols)
+-- in the implication, but taking care to only wrap those variables
+-- that are mentioned in the type or the implication.
+wrapTypeWithImplication :: Type -> Implication -> Type
+wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens
+    where givens = map idType $ ic_given impl
+          skols = ic_skols impl
+          freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens)
+          mentioned_skols = filter (`elemVarSet` freeVars) skols
+
+wrapType :: Type -> [TyVar] -> [PredType] -> Type
+wrapType ty skols givens = mkSpecForAllTys skols $ mkFunTys givens ty
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -2492,15 +2755,6 @@ For Givens we make new EvVars and bind them immediately. Two main reasons:
 
 So a Given has EvVar inside it rather than (as previously) an EvTerm.
 
-Note [Given in ctEvCoercion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When retrieving the evidence from a Given equality, we update the type of the EvVar
-from the ctev_pred field. In Note [Evidence field of CtEvidence], we claim that
-the type of the evidence is never looked at -- but this isn't true in the case of
-a coercion that is used in a type. (See the comments in Note [Flattening] in TcFlatten
-about the FTRNotFollowed case of flattenTyVar.) So, right here where we are retrieving
-the coercion from a Given, we update the type to make sure it's zonked.
-
 -}
 
 -- | A place for type-checking evidence to go after it is generated.
@@ -2554,27 +2808,29 @@ ctEvRole :: CtEvidence -> Role
 ctEvRole = eqRelRole . ctEvEqRel
 
 ctEvTerm :: CtEvidence -> EvTerm
-ctEvTerm ev@(CtWanted { ctev_dest = HoleDest _ }) = EvCoercion $ ctEvCoercion ev
-ctEvTerm ev = EvId (ctEvId ev)
+ctEvTerm ev = EvExpr (ctEvExpr ev)
+
+ctEvExpr :: CtEvidence -> EvExpr
+ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ })
+            = Coercion $ ctEvCoercion ev
+ctEvExpr ev = evId (ctEvEvId ev)
 
--- Always returns a coercion whose type is precisely ctev_pred of the CtEvidence.
--- See also Note [Given in ctEvCoercion]
 ctEvCoercion :: CtEvidence -> Coercion
-ctEvCoercion (CtGiven { ctev_pred = pred_ty, ctev_evar = ev_id })
-  = mkTcCoVarCo (setVarType ev_id pred_ty)  -- See Note [Given in ctEvCoercion]
-ctEvCoercion (CtWanted { ctev_dest = dest, ctev_pred = pred })
+ctEvCoercion (CtGiven { ctev_evar = ev_id })
+  = mkTcCoVarCo ev_id
+ctEvCoercion (CtWanted { ctev_dest = dest })
   | HoleDest hole <- dest
-  , Just (role, ty1, ty2) <- getEqPredTys_maybe pred
   = -- ctEvCoercion is only called on type equalities
     -- and they always have HoleDests
-    mkHoleCo hole role ty1 ty2
+    mkHoleCo hole
 ctEvCoercion ev
   = pprPanic "ctEvCoercion" (ppr ev)
 
-ctEvId :: CtEvidence -> TcId
-ctEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev
-ctEvId (CtGiven  { ctev_evar = ev }) = ev
-ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)
+ctEvEvId :: CtEvidence -> EvVar
+ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev
+ctEvEvId (CtWanted { ctev_dest = HoleDest h })   = coHoleCoVar h
+ctEvEvId (CtGiven  { ctev_evar = ev })           = ev
+ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev)
 
 instance Outputable TcEvDest where
   ppr (HoleDest h)   = text "hole" <> ppr h
@@ -2677,9 +2933,21 @@ type CtFlavourRole = (CtFlavour, EqRel)
 ctEvFlavourRole :: CtEvidence -> CtFlavourRole
 ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)
 
--- | Extract the flavour, role, and boxity from a 'Ct'
+-- | Extract the flavour and role from a 'Ct'
 ctFlavourRole :: Ct -> CtFlavourRole
-ctFlavourRole = ctEvFlavourRole . cc_ev
+-- Uses short-cuts to role for special cases
+ctFlavourRole (CDictCan { cc_ev = ev })
+  = (ctEvFlavour ev, NomEq)
+ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
+  = (ctEvFlavour ev, eq_rel)
+ctFlavourRole (CFunEqCan { cc_ev = ev })
+  = (ctEvFlavour ev, NomEq)
+ctFlavourRole (CHoleCan { cc_ev = ev })
+  = (ctEvFlavour ev, NomEq)  -- NomEq: CHoleCans can be rewritten by
+                             -- by nominal equalities but empahatically
+                             -- not by representational equalities
+ctFlavourRole ct
+  = ctEvFlavourRole (ctEvidence ct)
 
 {- Note [eqCanRewrite]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -2726,14 +2994,18 @@ ReprEq we could conceivably get a Derived NomEq improvement (by decomposing
 a type constructor with Nomninal role), and hence unify.
 -}
 
+eqCanRewrite :: EqRel -> EqRel -> Bool
+eqCanRewrite NomEq  _      = True
+eqCanRewrite ReprEq ReprEq = True
+eqCanRewrite ReprEq NomEq  = False
+
 eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool
 -- Can fr1 actually rewrite fr2?
 -- Very important function!
 -- See Note [eqCanRewrite]
 -- See Note [Wanteds do not rewrite Wanteds]
 -- See Note [Deriveds do rewrite Deriveds]
-eqCanRewriteFR (Given, NomEq)         (_, _)           = True
-eqCanRewriteFR (Given, ReprEq)        (_, ReprEq)      = True
+eqCanRewriteFR (Given,         r1)    (_,       r2)    = eqCanRewrite r1 r2
 eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True
 eqCanRewriteFR (Derived,       NomEq) (Derived, NomEq) = True
 eqCanRewriteFR _                      _                = False
@@ -2803,14 +3075,10 @@ We /do/ say that a [W] can discharge a [WD].  In evidence terms it
 certainly can, and the /caller/ arranges that the otherwise-lost [D]
 is spat out as a new Derived.  -}
 
-eqCanDischarge :: CtEvidence -> CtEvidence -> Bool
--- See Note [eqCanDischarge]
-eqCanDischarge ev1 ev2 = eqCanDischargeFR (ctEvFlavourRole ev1)
-                                          (ctEvFlavourRole ev2)
-
 eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool
-eqCanDischargeFR (_, ReprEq) (_, NomEq) = False
-eqCanDischargeFR (f1,_)      (f2, _)    = eqCanDischargeF f1 f2
+-- See Note [eqCanDischarge]
+eqCanDischargeFR (f1,r1) (f2, r2) =  eqCanRewrite r1 r2
+                                  && eqCanDischargeF f1 f2
 
 eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool
 eqCanDischargeF Given   _                  = True
@@ -2855,7 +3123,7 @@ level.
 equalities involving type functions. Example:
   Assume we have a wanted at depth 7:
     [W] d{7} : F () ~ a
-  If there is an type function equation "F () = Int", this would be rewritten to
+  If there is a type function equation "F () = Int", this would be rewritten to
     [W] d{8} : Int ~ a
   and remembered as having depth 8.
 
@@ -2904,25 +3172,20 @@ The 'CtLoc' gives information about where a constraint came from.
 This is important for decent error message reporting because
 dictionaries don't appear in the original source code.
 type will evolve...
+
 -}
 
 data CtLoc = CtLoc { ctl_origin :: CtOrigin
                    , ctl_env    :: TcLclEnv
                    , ctl_t_or_k :: Maybe TypeOrKind  -- OK if we're not sure
                    , ctl_depth  :: !SubGoalDepth }
+
   -- The TcLclEnv includes particularly
   --    source location:  tcl_loc   :: RealSrcSpan
   --    context:          tcl_ctxt  :: [ErrCtxt]
-  --    binder stack:     tcl_bndrs :: TcIdBinderStack
+  --    binder stack:     tcl_bndrs :: TcBinderStack
   --    level:            tcl_tclvl :: TcLevel
 
-mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
-mkGivenLoc tclvl skol_info env
-  = CtLoc { ctl_origin = GivenOrigin skol_info
-          , ctl_env    = env { tcl_tclvl = tclvl }
-          , ctl_t_or_k = Nothing    -- this only matters for error msgs
-          , ctl_depth  = initialSubGoalDepth }
-
 mkKindLoc :: TcType -> TcType   -- original *types* being compared
           -> CtLoc -> CtLoc
 mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)
@@ -2933,6 +3196,13 @@ mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)
 toKindLoc :: CtLoc -> CtLoc
 toKindLoc loc = loc { ctl_t_or_k = Just KindLevel }
 
+mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc
+mkGivenLoc tclvl skol_info env
+  = CtLoc { ctl_origin = GivenOrigin skol_info
+          , ctl_env    = env { tcl_tclvl = tclvl }
+          , ctl_t_or_k = Nothing    -- this only matters for error msgs
+          , ctl_depth  = initialSubGoalDepth }
+
 ctLocEnv :: CtLoc -> TcLclEnv
 ctLocEnv = ctl_env
 
@@ -2960,6 +3230,10 @@ bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDept
 setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
 setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
 
+updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc
+updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd
+  = ctl { ctl_origin = upd orig }
+
 setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc
 setCtLocEnv ctl env = ctl { ctl_env = env }
 
@@ -2993,7 +3267,11 @@ data SkolemInfo
        [(Name,TcTyVar)]    -- Maps the original name of the skolemised tyvar
                            -- to its instantiated version
 
-  | ClsSkol Class       -- Bound at a class decl
+  | SigTypeSkol UserTypeCtxt
+                 -- like SigSkol, but when we're kind-checking the *type*
+                 -- hence, we have less info
+
+  | ForAllSkol SDoc     -- Bound by a user-written "forall".
 
   | DerivSkol Type      -- Bound by a 'deriving' clause;
                         -- the type is the instance we are trying to derive
@@ -3005,7 +3283,6 @@ data SkolemInfo
                         --    then TypeSize = sizeTypes [ty1, .., tyn]
                         -- See Note [Solving superclass constraints] in TcInstDcls
 
-  | DataSkol            -- Bound at a data type declaration
   | FamInstSkol         -- Bound at a family instance decl
   | PatSkol             -- An existential type variable bound by a pattern for
       ConLike           -- a data constructor with an existential type.
@@ -3031,39 +3308,46 @@ data SkolemInfo
   | UnifyForAllSkol     -- We are unifying two for-all types
        TcType           -- The instantiated type *inside* the forall
 
+  | TyConSkol TyConFlavour Name  -- bound in a type declaration of the given flavour
+
+  | DataConSkol Name    -- bound as an existential in a Haskell98 datacon decl or
+                        -- as any variable in a GADT datacon decl
+
+  | ReifySkol           -- Bound during Template Haskell reification
+
+  | QuantCtxtSkol       -- Quantified context, e.g.
+                        --   f :: forall c. (forall a. c a => c [a]) => blah
+
   | UnkSkol             -- Unhelpful info (until I improve it)
 
 instance Outputable SkolemInfo where
   ppr = pprSkolInfo
 
-termEvidenceAllowed :: SkolemInfo -> Bool
--- Whether an implication constraint with this SkolemInfo
--- is permitted to have term-level evidence.  There is
--- only one that is not, associated with unifiying
--- forall-types
-termEvidenceAllowed (UnifyForAllSkol {}) = False
-termEvidenceAllowed _                    = True
-
 pprSkolInfo :: SkolemInfo -> SDoc
 -- Complete the sentence "is a rigid type variable bound by..."
 pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
+pprSkolInfo (SigTypeSkol cx)  = pprUserTypeCtxt cx
+pprSkolInfo (ForAllSkol doc)  = quotes doc
 pprSkolInfo (IPSkol ips)      = text "the implicit-parameter binding" <> plural ips <+> text "for"
                                  <+> pprWithCommas ppr ips
-pprSkolInfo (ClsSkol cls)     = text "the class declaration for" <+> quotes (ppr cls)
 pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred)
 pprSkolInfo InstSkol          = text "the instance declaration"
-pprSkolInfo (InstSC n)        = text "the instance declaration" <> ifPprDebug (parens (ppr n))
-pprSkolInfo DataSkol          = text "a data type declaration"
+pprSkolInfo (InstSC n)        = text "the instance declaration" <> whenPprDebug (parens (ppr n))
 pprSkolInfo FamInstSkol       = text "a family instance declaration"
 pprSkolInfo BracketSkol       = text "a Template Haskell bracket"
 pprSkolInfo (RuleSkol name)   = text "the RULE" <+> pprRuleName name
 pprSkolInfo ArrowSkol         = text "an arrow form"
 pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl
                                     , text "in" <+> pprMatchContext mc ]
-pprSkolInfo (InferSkol ids)   = sep [ text "the inferred type of"
-                                    , vcat [ ppr name <+> dcolon <+> ppr ty
-                                           | (name,ty) <- ids ]]
+pprSkolInfo (InferSkol ids)   = hang (text "the inferred type" <> plural ids <+> text "of")
+                                   2 (vcat [ ppr name <+> dcolon <+> ppr ty
+                                                   | (name,ty) <- ids ])
 pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty
+pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name)
+pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name)
+pprSkolInfo ReifySkol         = text "the type being reified"
+
+pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context"
 
 -- UnkSkol
 -- For type variables the others are dealt with by pprSkolTvBinding.
@@ -3150,11 +3434,15 @@ data CtOrigin
 
   | TypeEqOrigin { uo_actual   :: TcType
                  , uo_expected :: TcType
-                 , uo_thing    :: Maybe ErrorThing
-                                  -- ^ The thing that has type "actual"
+                 , uo_thing    :: Maybe SDoc
+                       -- ^ The thing that has type "actual"
+                 , uo_visible  :: Bool
+                       -- ^ Is at least one of the three elements above visible?
+                       -- (Errors from the polymorphic subsumption check are considered
+                       -- visible.) Only used for prioritizing error messages.
                  }
 
-  | KindEqOrigin
+  | KindEqOrigin  -- See Note [Equalities with incompatible kinds] in TcCanonical.
       TcType (Maybe TcType)     -- A kind equality arising from unifying these two types
       CtOrigin                  -- originally arising from this
       (Maybe TypeOrKind)        -- the level of the eq this arises from
@@ -3166,7 +3454,6 @@ data CtOrigin
   | NegateOrigin                        -- Occurrence of syntactic negation
 
   | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc
-  | PArrSeqOrigin  (ArithSeqInfo GhcRn) -- [:x..y:] and [:x,y..z:]
   | SectionOrigin
   | TupleOrigin                        -- (..,..)
   | ExprSigOrigin       -- e :: ty
@@ -3183,13 +3470,24 @@ data CtOrigin
                         --    then TypeSize = sizeTypes [ty1, .., tyn]
                         -- See Note [Solving superclass constraints] in TcInstDcls
 
-  | DerivOrigin         -- Typechecking deriving
-  | DerivOriginDC DataCon Int
-                        -- Checking constraints arising from this data con and field index
-  | DerivOriginCoerce Id Type Type
+  | DerivClauseOrigin   -- Typechecking a deriving clause (as opposed to
+                        -- standalone deriving).
+  | DerivOriginDC DataCon Int Bool
+      -- Checking constraints arising from this data con and field index. The
+      -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if
+      -- standalong deriving (with a wildcard constraint) is being used. This
+      -- is used to inform error messages on how to recommended fixes (e.g., if
+      -- the argument is True, then don't recommend "use standalone deriving",
+      -- but rather "fill in the wildcard constraint yourself").
+      -- See Note [Inferring the instance context] in TcDerivInfer
+  | DerivOriginCoerce Id Type Type Bool
                         -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
                         -- `ty1` to `ty2`.
-  | StandAloneDerivOrigin -- Typechecking stand-alone deriving
+  | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for
+                          -- constraints coming from a wildcard constraint,
+                          -- e.g., deriving instance _ => Eq (Foo a)
+                          -- See Note [Inferring the instance context]
+                          -- in TcDerivInfer
   | DefaultOrigin       -- Typechecking a default decl
   | DoOrigin            -- Arising from a do expression
   | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
@@ -3227,13 +3525,6 @@ data CtOrigin
         -- Skolem variable arose when we were testing if an instance
         -- is solvable or not.
 
--- | A thing that can be stored for error message generation only.
--- It is stored with a function to zonk and tidy the thing.
-data ErrorThing
-  = forall a. Outputable a => ErrorThing a
-                                         (Maybe Arity)  -- # of args, if known
-                                         (TidyEnv -> a -> TcM (TidyEnv, a))
-
 -- | Flag to see whether we're type-checking terms or kind-checking types
 data TypeOrKind = TypeLevel | KindLevel
   deriving Eq
@@ -3250,20 +3541,24 @@ isKindLevel :: TypeOrKind -> Bool
 isKindLevel TypeLevel = False
 isKindLevel KindLevel = True
 
--- | Make an 'ErrorThing' that doesn't need tidying or zonking
-mkErrorThing :: Outputable a => a -> ErrorThing
-mkErrorThing thing = ErrorThing thing Nothing (\env x -> return (env, x))
-
--- | Retrieve the # of arguments in the error thing, if known
-errorThingNumArgs_maybe :: ErrorThing -> Maybe Arity
-errorThingNumArgs_maybe (ErrorThing _ args _) = args
+-- An origin is visible if the place where the constraint arises is manifest
+-- in user code. Currently, all origins are visible except for invisible
+-- TypeEqOrigins. This is used when choosing which error of
+-- several to report
+isVisibleOrigin :: CtOrigin -> Bool
+isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis
+isVisibleOrigin (KindEqOrigin _ _ sub_orig _)       = isVisibleOrigin sub_orig
+isVisibleOrigin _                                   = True
+
+-- Converts a visible origin to an invisible one, if possible. Currently,
+-- this works only for TypeEqOrigin
+toInvisibleOrigin :: CtOrigin -> CtOrigin
+toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False }
+toInvisibleOrigin orig                   = orig
 
 instance Outputable CtOrigin where
   ppr = pprCtOrigin
 
-instance Outputable ErrorThing where
-  ppr (ErrorThing thing _ _) = ppr thing
-
 ctoHerald :: SDoc
 ctoHerald = text "arising from"
 
@@ -3272,58 +3567,55 @@ lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
 lexprCtOrigin (L _ e) = exprCtOrigin e
 
 exprCtOrigin :: HsExpr GhcRn -> CtOrigin
-exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
-exprCtOrigin (HsUnboundVar uv)  = UnboundOccurrenceOf (unboundVarOcc uv)
-exprCtOrigin (HsConLikeOut {})  = panic "exprCtOrigin HsConLikeOut"
-exprCtOrigin (HsRecFld f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
-exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
-exprCtOrigin (HsIPVar ip)       = IPOccOrigin ip
-exprCtOrigin (HsOverLit lit)    = LiteralOrigin lit
-exprCtOrigin (HsLit {})         = Shouldn'tHappenOrigin "concrete literal"
-exprCtOrigin (HsLam matches)    = matchesCtOrigin matches
-exprCtOrigin (HsLamCase ms)     = matchesCtOrigin ms
-exprCtOrigin (HsApp e1 _)       = lexprCtOrigin e1
-exprCtOrigin (HsAppType e1 _)   = lexprCtOrigin e1
-exprCtOrigin (HsAppTypeOut {})  = panic "exprCtOrigin HsAppTypeOut"
-exprCtOrigin (OpApp _ op _ _)   = lexprCtOrigin op
-exprCtOrigin (NegApp e _)       = lexprCtOrigin e
-exprCtOrigin (HsPar e)          = lexprCtOrigin e
-exprCtOrigin (SectionL _ _)     = SectionOrigin
-exprCtOrigin (SectionR _ _)     = SectionOrigin
-exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
-exprCtOrigin ExplicitSum{}      = Shouldn'tHappenOrigin "explicit sum"
-exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
-exprCtOrigin (HsIf {})          = Shouldn'tHappenOrigin "if expression"
-exprCtOrigin (HsMultiIf _ rhs)  = lGRHSCtOrigin rhs
-exprCtOrigin (HsLet _ e)        = lexprCtOrigin e
-exprCtOrigin (HsDo _ _ _)       = DoOrigin
-exprCtOrigin (ExplicitList {})  = Shouldn'tHappenOrigin "list"
-exprCtOrigin (ExplicitPArr {})  = Shouldn'tHappenOrigin "parallel array"
-exprCtOrigin (RecordCon {})     = Shouldn'tHappenOrigin "record construction"
-exprCtOrigin (RecordUpd {})     = Shouldn'tHappenOrigin "record update"
-exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
-exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut"
-exprCtOrigin (ArithSeq {})      = Shouldn'tHappenOrigin "arithmetic sequence"
-exprCtOrigin (PArrSeq {})       = Shouldn'tHappenOrigin "parallel array sequence"
-exprCtOrigin (HsSCC _ _ e)      = lexprCtOrigin e
-exprCtOrigin (HsCoreAnn _ _ e)  = lexprCtOrigin e
-exprCtOrigin (HsBracket {})     = Shouldn'tHappenOrigin "TH bracket"
+exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
+exprCtOrigin (HsUnboundVar _ uv)  = UnboundOccurrenceOf (unboundVarOcc uv)
+exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut"
+exprCtOrigin (HsRecFld _ f)    = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
+exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l
+exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip
+exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit
+exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"
+exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches
+exprCtOrigin (HsLamCase _ ms)     = matchesCtOrigin ms
+exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1
+exprCtOrigin (HsAppType _ e1)     = lexprCtOrigin e1
+exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
+exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
+exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
+exprCtOrigin (SectionL _ _ _)     = SectionOrigin
+exprCtOrigin (SectionR _ _ _)     = SectionOrigin
+exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
+exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
+exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
+exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
+exprCtOrigin (HsIf {})           = Shouldn'tHappenOrigin "if expression"
+exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
+exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
+exprCtOrigin (HsDo {})           = DoOrigin
+exprCtOrigin (ExplicitList {})   = Shouldn'tHappenOrigin "list"
+exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"
+exprCtOrigin (RecordUpd {})      = Shouldn'tHappenOrigin "record update"
+exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
+exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
+exprCtOrigin (HsSCC _ _ _ e)     = lexprCtOrigin e
+exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsBracket {})      = Shouldn'tHappenOrigin "TH bracket"
 exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
 exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
-exprCtOrigin (HsSpliceE {})     = Shouldn'tHappenOrigin "TH splice"
-exprCtOrigin (HsProc {})        = Shouldn'tHappenOrigin "proc"
-exprCtOrigin (HsStatic {})      = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (HsArrApp {})      = panic "exprCtOrigin HsArrApp"
-exprCtOrigin (HsArrForm {})     = panic "exprCtOrigin HsArrForm"
-exprCtOrigin (HsTick _ e)       = lexprCtOrigin e
-exprCtOrigin (HsBinTick _ _ e)  = lexprCtOrigin e
-exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e
-exprCtOrigin EWildPat           = panic "exprCtOrigin EWildPat"
+exprCtOrigin (HsSpliceE {})      = Shouldn'tHappenOrigin "TH splice"
+exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
+exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
+exprCtOrigin (HsArrApp {})       = panic "exprCtOrigin HsArrApp"
+exprCtOrigin (HsArrForm {})      = panic "exprCtOrigin HsArrForm"
+exprCtOrigin (HsTick _ _ e)           = lexprCtOrigin e
+exprCtOrigin (HsBinTick _ _ _ e)      = lexprCtOrigin e
+exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (EWildPat {})      = panic "exprCtOrigin EWildPat"
 exprCtOrigin (EAsPat {})        = panic "exprCtOrigin EAsPat"
 exprCtOrigin (EViewPat {})      = panic "exprCtOrigin EViewPat"
 exprCtOrigin (ELazyPat {})      = panic "exprCtOrigin ELazyPat"
 exprCtOrigin (HsWrap {})        = panic "exprCtOrigin HsWrap"
+exprCtOrigin (XExpr {})         = panic "exprCtOrigin XExpr"
 
 -- | Extract a suitable CtOrigin from a MatchGroup
 matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -3334,14 +3626,17 @@ matchesCtOrigin (MG { mg_alts = alts })
 
   | otherwise
   = Shouldn'tHappenOrigin "multi-way match"
+matchesCtOrigin (XMatchGroup{}) = panic "matchesCtOrigin"
 
 -- | Extract a suitable CtOrigin from guarded RHSs
 grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
 grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss
+grhssCtOrigin (XGRHSs _) = panic "grhssCtOrigin"
 
 -- | Extract a suitable CtOrigin from a list of guarded RHSs
 lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
-lGRHSCtOrigin [L _ (GRHS _ (L _ e))] = exprCtOrigin e
+lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
+lGRHSCtOrigin [L _ (XGRHS _)] = panic "lGRHSCtOrigin"
 lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"
 
 pprCtLoc :: CtLoc -> SDoc
@@ -3385,14 +3680,14 @@ pprCtOrigin (KindEqOrigin t1 Nothing _ _)
 pprCtOrigin (UnboundOccurrenceOf name)
   = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)
 
-pprCtOrigin (DerivOriginDC dc n)
+pprCtOrigin (DerivOriginDC dc n _)
   = hang (ctoHerald <+> text "the" <+> speakNth n
           <+> text "field of" <+> quotes (ppr dc))
        2 (parens (text "type" <+> quotes (ppr ty)))
   where
     ty = dataConOrigArgTys dc !! (n-1)
 
-pprCtOrigin (DerivOriginCoerce meth ty1 ty2)
+pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _)
   = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))
        2 (sep [ text "from type" <+> quotes (ppr ty1)
               , nest 2 $ text "to type" <+> quotes (ppr ty2) ])
@@ -3448,19 +3743,18 @@ pprCtO ViewPatOrigin         = text "a view pattern"
 pprCtO IfOrigin              = text "an if expression"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
-pprCtO (PArrSeqOrigin seq)   = hsep [text "the parallel array sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
 pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"
 pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"
-                               <> ifPprDebug (parens (ppr n))
-pprCtO DerivOrigin           = text "the 'deriving' clause of a data type declaration"
+                               <> whenPprDebug (parens (ppr n))
+pprCtO DerivClauseOrigin     = text "the 'deriving' clause of a data type declaration"
 pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
 pprCtO DefaultOrigin         = text "a 'default' declaration"
 pprCtO DoOrigin              = text "a do statement"
 pprCtO MCompOrigin           = text "a statement in a monad comprehension"
 pprCtO ProcOrigin            = text "a proc expression"
-pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
+pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
 pprCtO AnnOrigin             = text "an annotation"
 pprCtO HoleOrigin            = text "a use of" <+> quotes (text "_")
 pprCtO ListOrigin            = text "an overloaded list"
@@ -3487,15 +3781,13 @@ instance Applicative TcPluginM where
   (<*>) = ap
 
 instance Monad TcPluginM where
-  fail x   = TcPluginM (const $ fail x)
+  fail = MonadFail.fail
   TcPluginM m >>= k =
     TcPluginM (\ ev -> do a <- m ev
                           runTcPluginM (k a) ev)
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail TcPluginM where
   fail x   = TcPluginM (const $ fail x)
-#endif
 
 runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a
 runTcPluginM (TcPluginM m) = m
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index 7225d4e81b..552aa38296 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -11,7 +11,10 @@ TcRules: Typechecking transformation rules
 
 module TcRules ( tcRules ) where
 
+import GhcPrelude
+
 import HsSyn
+import TcRnTypes
 import TcRnMonad
 import TcSimplify
 import TcMType
@@ -22,8 +25,10 @@ import TcEnv
 import TcUnify( buildImplicationFor )
 import TcEvidence( mkTcCoVarCo )
 import Type
+import TyCon( isTypeFamilyTyCon )
 import Id
 import Var( EvVar )
+import VarSet
 import BasicTypes       ( RuleName )
 import SrcLoc
 import Outputable
@@ -53,40 +58,29 @@ tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]
 tcRules decls = mapM (wrapLocM tcRuleDecls) decls
 
 tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
-tcRuleDecls (HsRules src decls)
+tcRuleDecls (HsRules _ src decls)
    = do { tc_decls <- mapM (wrapLocM tcRule) decls
-        ; return (HsRules src tc_decls) }
+        ; return (HsRules noExt src tc_decls) }
+tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"
 
 tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
-tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-  = addErrCtxt (ruleCtxt $ snd $ unLoc name)  $
-    do { traceTc "---- Rule ------" (pprFullRuleName name)
+tcRule (HsRule fvs rname@(L _ (_,name))
+               act hs_bndrs lhs rhs)
+  = addErrCtxt (ruleCtxt name)  $
+    do { traceTc "---- Rule ------" (pprFullRuleName rname)
 
         -- Note [Typechecking rules]
-       ; (vars, bndr_wanted) <- captureConstraints $
-                                tcRuleBndrs hs_bndrs
-              -- bndr_wanted constraints can include wildcard hole
-              -- constraints, which we should not forget about.
-              -- It may mention the skolem type variables bound by
-              -- the RULE.  c.f. Trac #10072
+       ; (stuff, tc_lvl) <- pushTcLevelM $
+                            generateRuleConstraints hs_bndrs lhs rhs
 
-       ; let (id_bndrs, tv_bndrs) = partition isId vars
-       ; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty)
-            <- tcExtendTyVarEnv tv_bndrs $
-               tcExtendIdEnv    id_bndrs $
-               do { -- See Note [Solve order for RULES]
-                    ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
-                  ; (rhs', rhs_wanted) <- captureConstraints $
-                                          tcMonoExpr rhs (mkCheckExpType rule_ty)
-                  ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
+       ; let ( id_bndrs, lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) = stuff
 
-       ; traceTc "tcRule 1" (vcat [ pprFullRuleName name
+       ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
                                   , ppr lhs_wanted
                                   , ppr rhs_wanted ])
-       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
-       ; (lhs_evs, residual_lhs_wanted) <- simplifyRule (snd $ unLoc name)
-                                              all_lhs_wanted
-                                              rhs_wanted
+
+       ; (lhs_evs, residual_lhs_wanted)
+            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
 
        -- SimplfyRule Plan, step 4
        -- Now figure out what to quantify over
@@ -107,7 +101,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level
                                       -- monomorphic bindings from the MR; test tc111
        ; qtkvs <- quantifyTyVars gbls forall_tkvs
-       ; traceTc "tcRule" (vcat [ pprFullRuleName name
+       ; traceTc "tcRule" (vcat [ pprFullRuleName rname
                                 , ppr forall_tkvs
                                 , ppr qtkvs
                                 , ppr rule_ty
@@ -119,26 +113,52 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        -- For the LHS constraints we must solve the remaining constraints
        -- (a) so that we report insoluble ones
        -- (b) so that we bind any soluble ones
-       ; let skol_info = RuleSkol (snd (unLoc name))
-       ; (lhs_implic, lhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs
+       ; let skol_info = RuleSkol name
+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs
                                          lhs_evs residual_lhs_wanted
-       ; (rhs_implic, rhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs
+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs
                                          lhs_evs rhs_wanted
 
        ; emitImplications (lhs_implic `unionBags` rhs_implic)
-       ; return (HsRule name act
-                    (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids))
-                    (mkHsDictLet lhs_binds lhs') fv_lhs
-                    (mkHsDictLet rhs_binds rhs') fv_rhs) }
+       ; return (HsRule fvs rname act
+                    (map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids))
+                    (mkHsDictLet lhs_binds lhs')
+                    (mkHsDictLet rhs_binds rhs')) }
+tcRule (XRuleDecl _) = panic "tcRule"
+
+generateRuleConstraints :: [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn
+                        -> TcM ( [TcId]
+                               , LHsExpr GhcTc, WantedConstraints
+                               , LHsExpr GhcTc, WantedConstraints
+                               , TcType )
+generateRuleConstraints hs_bndrs lhs rhs
+  = do { (vars, bndr_wanted) <- captureConstraints $
+                                tcRuleBndrs hs_bndrs
+              -- bndr_wanted constraints can include wildcard hole
+              -- constraints, which we should not forget about.
+              -- It may mention the skolem type variables bound by
+              -- the RULE.  c.f. Trac #10072
+
+       ; let (id_bndrs, tv_bndrs) = partition isId vars
+       ; tcExtendTyVarEnv tv_bndrs $
+         tcExtendIdEnv    id_bndrs $
+    do { -- See Note [Solve order for RULES]
+         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
+       ; (rhs',            rhs_wanted) <- captureConstraints $
+                                          tcMonoExpr rhs (mkCheckExpType rule_ty)
+       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
+       ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+                -- Slightly curious that tv_bndrs is not returned
+
 
 tcRuleBndrs :: [LRuleBndr GhcRn] -> TcM [Var]
 tcRuleBndrs []
   = return []
-tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
   = do  { ty <- newOpenFlexiTyVarTy
         ; vars <- tcRuleBndrs rule_bndrs
         ; return (mkLocalId name ty : vars) }
-tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs)
+tcRuleBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
 --  e.g         x :: a->a
 --  The tyvar 'a' is brought into scope first, just as if you'd written
 --              a::*, x :: a->a
@@ -148,9 +168,10 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs)
                     -- See Note [Pattern signature binders] in TcHsType
 
               -- The type variables scope over subsequent bindings; yuk
-        ; vars <- tcExtendTyVarEnv2 tvs $
+        ; vars <- tcExtendNameTyVarEnv tvs $
                   tcRuleBndrs rule_bndrs
         ; return (map snd tvs ++ id : vars) }
+tcRuleBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleBndrs"
 
 ruleCtxt :: FastString -> SDoc
 ruleCtxt name = text "When checking the transformation rule" <+>
@@ -251,7 +272,7 @@ where 'alpha' is the type that connects the two.  If we glom them
 all together, and solve the RHS constraint first, we might solve
 with alpha := Bool.  But then we'd end up with a RULE like
 
-    RULE: f 3 |> (co :: T Int ~ Booo) = True
+    RULE: f 3 |> (co :: T Int ~ Bool) = True
 
 which is terrible.  We want
 
@@ -299,6 +320,7 @@ terrible, so we avoid the problem by cloning the constraints.
 -}
 
 simplifyRule :: RuleName
+             -> TcLevel                 -- Level at which to solve the constraints
              -> WantedConstraints       -- Constraints from LHS
              -> WantedConstraints       -- Constraints from RHS
              -> TcM ( [EvVar]               -- Quantify over these LHS vars
@@ -306,53 +328,40 @@ simplifyRule :: RuleName
 -- See Note [The SimplifyRule Plan]
 -- NB: This consumes all simple constraints on the LHS, but not
 -- any LHS implication constraints.
-simplifyRule name lhs_wanted rhs_wanted
-  = do {         -- We allow ourselves to unify environment
-                 -- variables: runTcS runs with topTcLevel
-       ; lhs_clone <- cloneWC lhs_wanted
-       ; rhs_clone <- cloneWC rhs_wanted
-
+simplifyRule name tc_lvl lhs_wanted rhs_wanted
+  = do {
        -- Note [The SimplifyRule Plan] step 1
        -- First solve the LHS and *then* solve the RHS
        -- Crucially, this performs unifications
-       -- See Note [Solve order for RULES]
-       -- See Note [Simplify cloned constraints]
-       ; insoluble <- runTcSDeriveds $
-             do { lhs_resid <- solveWanteds lhs_clone
-                ; rhs_resid <- solveWanteds rhs_clone
-                ; return ( insolubleWC lhs_resid ||
-                           insolubleWC rhs_resid ) }
+       -- Why clone?  See Note [Simplify cloned constraints]
+       ; lhs_clone <- cloneWC lhs_wanted
+       ; rhs_clone <- cloneWC rhs_wanted
+       ; setTcLevel tc_lvl $
+         runTcSDeriveds    $
+         do { _ <- solveWanteds lhs_clone
+            ; _ <- solveWanteds rhs_clone
+                  -- Why do them separately?
+                  -- See Note [Solve order for RULES]
+            ; return () }
 
        -- Note [The SimplifyRule Plan] step 2
-       ; zonked_lhs_simples <- zonkSimples (wc_simple lhs_wanted)
+       ; lhs_wanted <- zonkWC lhs_wanted
+       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
 
        -- Note [The SimplifyRule Plan] step 3
-       ; let (quant_cts, no_quant_cts) = partitionBag (quantify_ct insoluble)
-                                                      zonked_lhs_simples
-
        ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
 
        ; traceTc "simplifyRule" $
          vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
               , text "lhs_wanted" <+> ppr lhs_wanted
               , text "rhs_wanted" <+> ppr rhs_wanted
-              , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples
               , text "quant_cts" <+> ppr quant_cts
-              , text "no_quant_cts" <+> ppr no_quant_cts
+              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
               ]
 
-       ; return (quant_evs, lhs_wanted { wc_simple = no_quant_cts }) }
+       ; return (quant_evs, residual_lhs_wanted) }
 
   where
-    quantify_ct :: Bool -> Ct -> Bool
-    quantify_ct insol ct
-      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)
-      = not (insol || t1 `tcEqType` t2)
-        -- Note [RULE quantification over equalities]
-
-      | otherwise
-      = True
-
     mk_quant_ev :: Ct -> TcM EvVar
     mk_quant_ev ct
       | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
@@ -363,3 +372,60 @@ simplifyRule name lhs_wanted rhs_wanted
                                 ; fillCoercionHole hole (mkTcCoVarCo ev_id)
                                 ; return ev_id }
     mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
+
+
+getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
+-- Extract all the constraints we can quantify over,
+--   also returning the depleted WantedConstraints
+--
+-- NB: we must look inside implications, because with
+--     -fdefer-type-errors we generate implications rather eagerly;
+--     see TcUnify.implicationNeeded. Not doing so caused Trac #14732.
+--
+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
+--   and attempt to solve them from the quantified constraints.  That
+--   nearly works, but fails for a constraint like (d :: Eq Int).
+--   We /do/ want to quantify over it, but the short-cut solver
+--   (see TcInteract Note [Shortcut solving]) ignores the quantified
+--   and instead solves from the top level.
+--
+--   So we must partition the WantedConstraints ourselves
+--   Not hard, but tiresome.
+
+getRuleQuantCts wc
+  = float_wc emptyVarSet wc
+  where
+    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = ( simple_yes `andCts` implic_yes
+        , WC { wc_simple = simple_no, wc_impl = implics_no })
+     where
+        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
+        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)
+                                                emptyBag implics
+
+    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
+    float_implic skol_tvs yes1 imp
+      = (yes1 `andCts` yes2, imp { ic_wanted = no })
+      where
+        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
+        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
+
+    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
+    rule_quant_ct skol_tvs ct
+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)
+      , not (ok_eq t1 t2)
+       = False        -- Note [RULE quantification over equalities]
+      | isHoleCt ct
+      = False         -- Don't quantify over type holes, obviously
+      | otherwise
+      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
+    ok_eq t1 t2
+       | t1 `tcEqType` t2 = False
+       | otherwise        = is_fun_app t1 || is_fun_app t2
+
+    is_fun_app ty   -- ty is of form (F tys) where F is a type function
+      = case tyConAppTyCon_maybe ty of
+          Just tc -> isTypeFamilyTyCon tc
+          Nothing -> False
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index b5f6554766..db29f67f86 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -5,7 +5,7 @@ module TcSMonad (
 
     -- The work list
     WorkList(..), isEmptyWorkList, emptyWorkList,
-    extendWorkListNonEq, extendWorkListCt, extendWorkListDerived,
+    extendWorkListNonEq, extendWorkListCt,
     extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
     appendWorkList, extendWorkListImplic,
     selectNextWorkItem,
@@ -16,9 +16,13 @@ module TcSMonad (
     TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
     failTcS, warnTcS, addErrTcS,
     runTcSEqualities,
-    nestTcS, nestImplicTcS, setEvBindsTcS, buildImplication,
+    nestTcS, nestImplicTcS, setEvBindsTcS,
+    checkConstraintsTcS, checkTvConstraintsTcS,
 
     runTcPluginTcS, addUsedGRE, addUsedGREs,
+    matchGlobalInst, TcM.ClsInstResult(..),
+
+    QCInst(..),
 
     -- Tracing etc
     panicTcS, traceTcS,
@@ -26,25 +30,25 @@ module TcSMonad (
     wrapErrTcS, wrapWarnTcS,
 
     -- Evidence creation and transformation
-    MaybeNew(..), freshGoals, isFresh, getEvTerm,
+    MaybeNew(..), freshGoals, isFresh, getEvExpr,
 
-    newTcEvBinds,
+    newTcEvBinds, newNoTcEvBinds,
     newWantedEq, emitNewWantedEq,
     newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,
     newBoundEvVarId,
     unifyTyVar, unflattenFmv, reportUnifications,
-    setEvBind, setWantedEq, setEqIfWanted,
-    setWantedEvTerm, setWantedEvBind, setEvBindIfWanted,
+    setEvBind, setWantedEq,
+    setWantedEvTerm, setEvBindIfWanted,
     newEvVar, newGivenEvVar, newGivenEvVars,
-    emitNewDerived, emitNewDeriveds, emitNewDerivedEq,
+    emitNewDeriveds, emitNewDerivedEq,
     checkReductionDepth,
+    getSolvedDicts, setSolvedDicts,
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getLclEnv,
     getTcEvBindsVar, getTcLevel,
-    getTcEvBindsAndTCVs, getTcEvBindsMap,
-    tcLookupClass,
-    tcLookupId,
+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+    tcLookupClass, tcLookupId,
 
     -- Inerts
     InertSet(..), InertCans(..),
@@ -53,11 +57,11 @@ module TcSMonad (
     getInertEqs, getInertCans, getInertGivens,
     getInertInsols,
     getTcSInerts, setTcSInerts,
-    matchableGivens, prohibitedSuperClassSolve,
+    matchableGivens, prohibitedSuperClassSolve, mightMatchLater,
     getUnsolvedInerts,
-    removeInertCts, getPendingScDicts,
-    addInertCan, addInertEq, insertFunEq,
-    emitInsoluble, emitWorkNC, emitWork,
+    removeInertCts, getPendingGivenScs,
+    addInertCan, insertFunEq, addInertForAll,
+    emitWorkNC, emitWork,
     isImprovable,
 
     -- The Model
@@ -83,6 +87,7 @@ module TcSMonad (
 
     -- The flattening cache
     lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems
+    dischargeFunEq, pprKicked,
 
     -- Inert CFunEqCans
     updInertFunEqs, findFunEq,
@@ -93,16 +98,17 @@ module TcSMonad (
     -- MetaTyVars
     newFlexiTcSTy, instFlexi, instFlexiX,
     cloneMetaTyVar, demoteUnfilledFmv,
-    tcInstType, tcInstSkolTyVarsX,
+    tcInstSkolTyVarsX,
 
-    TcLevel, isTouchableMetaTyVarTcS,
+    TcLevel,
     isFilledMetaTyVar_maybe, isFilledMetaTyVar,
     zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
     zonkTyCoVarsAndFVList,
     zonkSimples, zonkWC,
+    zonkTcTyCoVarBndr,
 
     -- References
-    newTcRef, readTcRef, updTcRef,
+    newTcRef, readTcRef, writeTcRef, updTcRef,
 
     -- Misc
     getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
@@ -117,6 +123,8 @@ module TcSMonad (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HscTypes
 
 import qualified Inst as TcM
@@ -126,13 +134,16 @@ import FamInstEnv
 
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
+import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) )
 import qualified TcEnv as TcM
-       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )
+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )
 import PrelNames( heqTyConKey, eqTyConKey )
+import ClsInst( InstanceWhat(..) )
 import Kind
 import TcType
 import DynFlags
 import Type
+import TyCoRep( coHoleCoVar )
 import Coercion
 import Unify
 
@@ -142,6 +153,7 @@ import TyCon
 import TcErrors   ( solverDepthErrorTcS )
 
 import Name
+import Module ( HasModule, getModule )
 import RdrName ( GlobalRdrEnv, GlobalRdrElt )
 import qualified RnEnv as TcM
 import Var
@@ -158,14 +170,12 @@ import UniqFM
 import UniqDFM
 import Maybes
 
-import TrieMap
+import CoreMap
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import MonadUtils
 import Data.IORef
-import Data.List ( foldl', partition )
+import Data.List ( foldl', partition, mapAccumL )
 
 #if defined(DEBUG)
 import Digraph
@@ -189,16 +199,44 @@ Notice that each Ct now has a simplification depth. We may
 consider using this depth for prioritization as well in the future.
 
 As a simple form of priority queue, our worklist separates out
-equalities (wl_eqs) from the rest of the canonical constraints,
-so that it's easier to deal with them first, but the separation
-is not strictly necessary. Notice that non-canonical constraints
-are also parts of the worklist.
 
-Note [Process derived items last]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We can often solve all goals without processing *any* derived constraints.
-The derived constraints are just there to help us if we get stuck.  So
-we keep them in a separate list.
+* equalities (wl_eqs); see Note [Prioritise equalities]
+* type-function equalities (wl_funeqs)
+* all the rest (wl_rest)
+
+Note [Prioritise equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to process equalities /first/:
+
+* (Efficiency)  The general reason to do so is that if we process a
+  class constraint first, we may end up putting it into the inert set
+  and then kicking it out later.  That's extra work compared to just
+  doing the equality first.
+
+* (Avoiding fundep iteration) As Trac #14723 showed, it's possible to
+  get non-termination if we
+      - Emit the Derived fundep equalities for a class constraint,
+        generating some fresh unification variables.
+      - That leads to some unification
+      - Which kicks out the class constraint
+      - Which isn't solved (because there are still some more Derived
+        equalities in the work-list), but generates yet more fundeps
+  Solution: prioritise derived equalities over class constraints
+
+* (Class equalities) We need to prioritise equalities even if they
+  are hidden inside a class constraint;
+  see Note [Prioritise class equalities]
+
+* (Kick-out) We want to apply this priority scheme to kicked-out
+  constraints too (see the call to extendWorkListCt in kick_out_rewritable
+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become
+  homo-kinded when kicked out, and hence we want to priotitise it.
+
+* (Derived equalities) Originally we tried to postpone processing
+  Derived equalities, in the hope that we might never need to deal
+  with them at all; but in fact we must process Derived equalities
+  eagerly, partly for the (Efficiency) reason, and more importantly
+  for (Avoiding fundep iteration).
 
 Note [Prioritise class equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -220,46 +258,50 @@ So we arrange to put these particular class constraints in the wl_eqs.
 
 -- See Note [WorkList priorities]
 data WorkList
-  = WL { wl_eqs     :: [Ct]  -- Both equality constraints and their
-                             -- class-level variants (a~b) and (a~~b);
-                             -- See Note [Prioritise class equalities]
+  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan
+                             -- Given, Wanted, and Derived
+                       -- Contains both equality constraints and their
+                       -- class-level variants (a~b) and (a~~b);
+                       -- See Note [Prioritise equalities]
+                       -- See Note [Prioritise class equalities]
 
-       , wl_funeqs  :: [Ct]  -- LIFO stack of goals
+       , wl_funeqs  :: [Ct]
 
        , wl_rest    :: [Ct]
 
-       , wl_deriv   :: [CtEvidence]  -- Implicitly non-canonical
-                                     -- See Note [Process derived items last]
-
        , wl_implics :: Bag Implication  -- See Note [Residual implications]
     }
 
 appendWorkList :: WorkList -> WorkList -> WorkList
 appendWorkList
     (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
-        , wl_deriv = ders1, wl_implics = implics1 })
+        , wl_implics = implics1 })
     (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
-        , wl_deriv = ders2, wl_implics = implics2 })
+        , wl_implics = implics2 })
    = WL { wl_eqs     = eqs1     ++ eqs2
         , wl_funeqs  = funeqs1  ++ funeqs2
         , wl_rest    = rest1    ++ rest2
-        , wl_deriv   = ders1    ++ ders2
         , wl_implics = implics1 `unionBags`   implics2 }
 
 workListSize :: WorkList -> Int
-workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_deriv = ders, wl_rest = rest })
-  = length eqs + length funeqs + length rest + length ders
+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
+  = length eqs + length funeqs + length rest
 
 workListWantedCount :: WorkList -> Int
+-- Count the things we need to solve
+-- excluding the insolubles (c.f. inert_count)
 workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
-  = count isWantedCt eqs + count isWantedCt rest
+  = count isWantedCt eqs + count is_wanted rest
+  where
+    is_wanted ct
+     | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct
+     = not insol && isWanted ev
+     | otherwise
+     = isWantedCt ct
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
 extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
 
-extendWorkListEqs :: [Ct] -> WorkList -> WorkList
-extendWorkListEqs cts wl = wl { wl_eqs = cts ++ wl_eqs wl }
-
 extendWorkListFunEq :: Ct -> WorkList -> WorkList
 extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
 
@@ -267,15 +309,9 @@ extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
 extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
 
-extendWorkListDerived :: CtLoc -> CtEvidence -> WorkList -> WorkList
-extendWorkListDerived loc ev wl
-  | isDroppableDerivedLoc loc = wl { wl_deriv = ev : wl_deriv wl }
-  | otherwise                 = extendWorkListEq (mkNonCanonical ev) wl
-
-extendWorkListDeriveds :: CtLoc -> [CtEvidence] -> WorkList -> WorkList
-extendWorkListDeriveds loc evs wl
-  | isDroppableDerivedLoc loc = wl { wl_deriv = evs ++ wl_deriv wl }
-  | otherwise                 = extendWorkListEqs (map mkNonCanonical evs) wl
+extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
+extendWorkListDeriveds evs wl
+  = extendWorkListCts (map mkNonCanonical evs) wl
 
 extendWorkListImplic :: Bag Implication -> WorkList -> WorkList
 extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }
@@ -305,14 +341,15 @@ extendWorkListCts cts wl = foldr extendWorkListCt wl cts
 
 isEmptyWorkList :: WorkList -> Bool
 isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
-                    , wl_rest = rest, wl_deriv = ders, wl_implics = implics })
-  = null eqs && null rest && null funeqs && isEmptyBag implics && null ders
+                    , wl_rest = rest, wl_implics = implics })
+  = null eqs && null rest && null funeqs && isEmptyBag implics
 
 emptyWorkList :: WorkList
 emptyWorkList = WL { wl_eqs  = [], wl_rest = []
-                   , wl_funeqs = [], wl_deriv = [], wl_implics = emptyBag }
+                   , wl_funeqs = [], wl_implics = emptyBag }
 
 selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
+-- See Note [Prioritise equalities]
 selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
                       , wl_rest = rest })
   | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })
@@ -324,36 +361,24 @@ getWorkList :: TcS WorkList
 getWorkList = do { wl_var <- getTcSWorkListRef
                  ; wrapTcS (TcM.readTcRef wl_var) }
 
-selectDerivedWorkItem  :: WorkList -> Maybe (Ct, WorkList)
-selectDerivedWorkItem wl@(WL { wl_deriv = ders })
-  | ev:evs <- ders = Just (mkNonCanonical ev, wl { wl_deriv  = evs })
-  | otherwise      = Nothing
-
 selectNextWorkItem :: TcS (Maybe Ct)
+-- Pick which work item to do next
+-- See Note [Prioritise equalities]
 selectNextWorkItem
   = do { wl_var <- getTcSWorkListRef
-       ; wl <- wrapTcS (TcM.readTcRef wl_var)
-
-       ; let try :: Maybe (Ct,WorkList) -> TcS (Maybe Ct) -> TcS (Maybe Ct)
-             try mb_work do_this_if_fail
-                | Just (ct, new_wl) <- mb_work
-                = do { checkReductionDepth (ctLoc ct) (ctPred ct)
-                     ; wrapTcS (TcM.writeTcRef wl_var new_wl)
-                     ; return (Just ct) }
-                | otherwise
-                = do_this_if_fail
-
-       ; try (selectWorkItem wl) $
-
-    do { ics <- getInertCans
-       ; if inert_count ics == 0
-         then return Nothing
-         else try (selectDerivedWorkItem wl) (return Nothing) } }
+       ; wl <- readTcRef wl_var
+       ; case selectWorkItem wl of {
+           Nothing -> return Nothing ;
+           Just (ct, new_wl) ->
+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)
+         -- This is done by TcInteract.chooseInstance
+       ; writeTcRef wl_var new_wl
+       ; return (Just ct) } } }
 
 -- Pretty printing
 instance Outputable WorkList where
   ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
-          , wl_rest = rest, wl_implics = implics, wl_deriv = ders })
+          , wl_rest = rest, wl_implics = implics })
    = text "WL" <+> (braces $
      vcat [ ppUnless (null eqs) $
             text "Eqs =" <+> vcat (map ppr eqs)
@@ -361,13 +386,9 @@ instance Outputable WorkList where
             text "Funeqs =" <+> vcat (map ppr feqs)
           , ppUnless (null rest) $
             text "Non-eqs =" <+> vcat (map ppr rest)
-          , ppUnless (null ders) $
-            text "Derived =" <+> vcat (map ppr ders)
           , ppUnless (isEmptyBag implics) $
-            sdocWithPprDebug $ \dbg ->
-            if dbg  -- Typically we only want the work list for this level
-            then text "Implics =" <+> vcat (map ppr (bagToList implics))
-            else text "(Implics omitted)"
+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))
+                       (text "(Implics omitted)")
           ])
 
 
@@ -409,30 +430,38 @@ data InertSet
               -- NB: An ExactFunEqMap -- this doesn't match via loose types!
 
        , inert_solved_dicts   :: DictMap CtEvidence
-              -- Of form ev :: C t1 .. tn
+              -- All Wanteds, of form ev :: C t1 .. tn
               -- See Note [Solved dictionaries]
               -- and Note [Do not add superclasses of solved dictionaries]
        }
 
 instance Outputable InertSet where
-  ppr is = vcat [ ppr $ inert_cans is
-                , ppUnless (null dicts) $
-                  text "Solved dicts" <+> vcat (map ppr dicts) ]
+  ppr (IS { inert_cans = ics
+          , inert_fsks = ifsks
+          , inert_solved_dicts = solved_dicts })
+      = vcat [ ppr ics
+             , text "Inert fsks =" <+> ppr ifsks
+             , ppUnless (null dicts) $
+               text "Solved dicts =" <+> vcat (map ppr dicts) ]
          where
-           dicts = bagToList (dictsToBag (inert_solved_dicts is))
+           dicts = bagToList (dictsToBag solved_dicts)
+
+emptyInertCans :: InertCans
+emptyInertCans
+  = IC { inert_count    = 0
+       , inert_eqs      = emptyDVarEnv
+       , inert_dicts    = emptyDicts
+       , inert_safehask = emptyDicts
+       , inert_funeqs   = emptyFunEqs
+       , inert_insts    = []
+       , inert_irreds   = emptyCts }
 
 emptyInert :: InertSet
 emptyInert
-  = IS { inert_cans = IC { inert_count    = 0
-                         , inert_eqs      = emptyDVarEnv
-                         , inert_dicts    = emptyDicts
-                         , inert_safehask = emptyDicts
-                         , inert_funeqs   = emptyFunEqs
-                         , inert_irreds   = emptyCts
-                         , inert_insols   = emptyCts }
-       , inert_flat_cache    = emptyExactFunEqs
-       , inert_fsks          = []
-       , inert_solved_dicts  = emptyDictMap }
+  = IS { inert_cans         = emptyInertCans
+       , inert_fsks         = []
+       , inert_flat_cache   = emptyExactFunEqs
+       , inert_solved_dicts = emptyDictMap }
 
 
 {- Note [Solved dictionaries]
@@ -459,8 +488,16 @@ Other notes about solved dictionaries
 
 * See also Note [Do not add superclasses of solved dictionaries]
 
-* The inert_solved_dicts field is not rewritten by equalities, so it may
-  get out of date.
+* The inert_solved_dicts field is not rewritten by equalities,
+  so it may get out of date.
+
+* THe inert_solved_dicts are all Wanteds, never givens
+
+* We only cache dictionaries from top-level instances, not from
+  local quantified constraints.  Reason: if we cached the latter
+  we'd need to purge the cache when bringing new quantified
+  constraints into scope, because quantified constraints "shadow"
+  top-level instances.
 
 Note [Do not add superclasses of solved dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -621,6 +658,8 @@ data InertCans   -- See Note [Detailed InertCans Invariants] for more
               -- All fully rewritten (modulo flavour constraints)
               --     wrt inert_eqs
 
+       , inert_insts :: [QCInst]
+
        , inert_safehask :: DictMap Ct
               -- Failed dictionary resolution due to Safe Haskell overlapping
               -- instances restriction. We keep this separate from inert_dicts
@@ -631,16 +670,15 @@ data InertCans   -- See Note [Detailed InertCans Invariants] for more
               -- in TcSimplify
 
        , inert_irreds :: Cts
-              -- Irreducible predicates
-
-       , inert_insols :: Cts
-              -- Frozen errors (as non-canonicals)
+              -- Irreducible predicates that cannot be made canonical,
+              --     and which don't interact with others (e.g.  (c a))
+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])
 
        , inert_count :: Int
               -- Number of Wanted goals in
               --     inert_eqs, inert_dicts, inert_safehask, inert_irreds
               -- Does not include insolubles
-              -- When non-zero, keep trying to solved
+              -- When non-zero, keep trying to solve
        }
 
 type InertEqs    = DTyVarEnv EqualCtList
@@ -779,36 +817,38 @@ guarantee that this recursive use will terminate.
 
 Note [Extending the inert equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Theorem [Stability under extension]
-   This is the main theorem!
+Main Theorem [Stability under extension]
    Suppose we have a "work item"
        a -fw-> t
    and an inert generalised substitution S,
-   such that
+   THEN the extended substitution T = S+(a -fw-> t)
+        is an inert generalised substitution
+   PROVIDED
       (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)
       (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)
       (T3) a not in t      -- No occurs check in the work item
 
-      (K1) for every (a -fs-> s) in S, then not (fw >= fs)
-           Reason: the work item is fully rewritten by S, hence not (fs >= fw)
-                   but if (fw >= fs) then the work item could rewrite
-                   the inert item
+      AND, for every (b -fs-> s) in S:
+           (K0) not (fw >= fs)
+                Reason: suppose we kick out (a -fs-> s),
+                        and add (a -fw-> t) to the inert set.
+                        The latter can't rewrite the former,
+                        so the kick-out achieved nothing
 
-      (K2) for every (b -fs-> s) in S, where b /= a, then
-              (K2a) not (fs >= fs)
-           or (K2b) fs >= fw
-           or (K2c) not (fw >= fs)
-           or (K2d) a not in s
+           OR { (K1) not (a = b)
+                     Reason: if fw >= fs, WF1 says we can't have both
+                             a -fw-> t  and  a -fs-> s
 
-      (K3) See Note [K3: completeness of solving]
-           If (b -fs-> s) is in S with (fw >= fs), then
-        (K3a) If the role of fs is nominal: s /= a
-        (K3b) If the role of fs is representational: EITHER
-                a not in s, OR
-                the path from the top of s to a includes at least one non-newtype
+                AND (K2): guarantees inertness of the new substitution
+                    {  (K2a) not (fs >= fs)
+                    OR (K2b) fs >= fw
+                    OR (K2d) a not in s }
+
+                AND (K3) See Note [K3: completeness of solving]
+                    { (K3a) If the role of fs is nominal: s /= a
+                      (K3b) If the role of fs is representational:
+                            s is not of form (a t1 .. tn) } }
 
-   then the extended substitution T = S+(a -fw-> t)
-   is an inert generalised substitution.
 
 Conditions (T1-T3) are established by the canonicaliser
 Conditions (K1-K3) are established by TcSMonad.kickOutRewritable
@@ -836,11 +876,12 @@ The idea is that
   us to kick out an inert wanted that mentions a, because of (K2a).  This
   is a common case, hence good not to kick out.
 
-* Lemma (L2): if not (fw >= fw), then K1-K3 all hold.
+* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing
   Proof: using Definition [Can-rewrite relation], fw can't rewrite anything
-         and so K1-K3 hold.  Intuitively, since fw can't rewrite anything,
+         and so K0 holds.  Intuitively, since fw can't rewrite anything,
          adding it cannot cause any loops
   This is a common case, because Wanteds cannot rewrite Wanteds.
+  It's used to avoid even looking for constraint to kick out.
 
 * Lemma (L1): The conditions of the Main Theorem imply that there is no
               (a -fs-> t) in S, s.t.  (fs >= fw).
@@ -853,9 +894,9 @@ The idea is that
   - (T3) guarantees (WF2).
 
 * (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),
-  T^1(f,t), T^2(f,T).... must pass through the new work item infnitely
+  T^1(f,t), T^2(f,T).... must pass through the new work item infinitely
   often, since the substitution without the work item is inert; and must
-  pass through at least one of the triples in S infnitely often.
+  pass through at least one of the triples in S infinitely often.
 
   - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),
     and hence this triple never plays a role in application S(f,a).
@@ -864,7 +905,7 @@ The idea is that
     (NB: we could strengten K1) in this way too, but see K3.
 
   - (K2b): If this holds then, by (T2), b is not in t.  So applying the
-    work item does not genenerate any new opportunities for applying S
+    work item does not generate any new opportunities for applying S
 
   - (K2c): If this holds, we can't pass through this triple infinitely
     often, because if we did then fs>=f, fw>=f, hence by (R2)
@@ -917,26 +958,35 @@ is somewhat accidental.
 
 When considering roles, we also need the second clause (K3b). Consider
 
-  inert-item   a -W/R-> b c
   work-item    c -G/N-> a
+  inert-item   a -W/R-> b c
 
 The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.
-We've satisfied conditions (T1)-(T3) and (K1) and (K2). If all we had were
-condition (K3a), then we would keep the inert around and add the work item.
-But then, consider if we hit the following:
-
-  work-item2   b -G/N-> Id
+But we don't kick out the inert item because not (W/R >= W/R).  So we just
+add the work item. But then, consider if we hit the following:
 
+  work-item    b -G/N-> Id
+  inert-items  a -W/R-> b c
+               c -G/N-> a
 where
-
   newtype Id x = Id x
 
 For similar reasons, if we only had (K3a), we wouldn't kick the
 representational inert out. And then, we'd miss solving the inert, which
-now reduced to reflexivity. The solution here is to kick out representational
-inerts whenever the tyvar of a work item is "exposed", where exposed means
-not under some proper data-type constructor, like [] or Maybe. See
-isTyVarExposed in TcType. This is encoded in (K3b).
+now reduced to reflexivity.
+
+The solution here is to kick out representational inerts whenever the
+tyvar of a work item is "exposed", where exposed means being at the
+head of the top-level application chain (a t1 .. tn).  See
+TcType.isTyVarHead. This is encoded in (K3b).
+
+Beware: if we make this test succeed too often, we kick out too much,
+and the solver might loop.  Consider (Trac #14363)
+  work item:   [G] a ~R f b
+  inert item:  [G] b ~R f a
+In GHC 8.2 the completeness tests more aggressive, and kicked out
+the inert item; but no rewriting happened and there was an infinite
+loop.  All we need is to have the tyvar at the head.
 
 Note [Flavours with roles]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -966,7 +1016,8 @@ instance Outputable InertCans where
   ppr (IC { inert_eqs = eqs
           , inert_funeqs = funeqs, inert_dicts = dicts
           , inert_safehask = safehask, inert_irreds = irreds
-          , inert_insols = insols, inert_count = count })
+          , inert_insts = insts
+          , inert_count = count })
     = braces $ vcat
       [ ppUnless (isEmptyDVarEnv eqs) $
         text "Equalities:"
@@ -979,8 +1030,8 @@ instance Outputable InertCans where
         text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)
       , ppUnless (isEmptyCts irreds) $
         text "Irreds =" <+> pprCts irreds
-      , ppUnless (isEmptyCts insols) $
-        text "Insolubles =" <+> pprCts insols
+      , ppUnless (null insts) $
+        text "Given instances =" <+> vcat (map ppr insts)
       , text "Unsolved goals =" <+> int count
       ]
 
@@ -1031,7 +1082,7 @@ The same idea is sometimes also called "saturation"; find all the
 equalities that must hold in any solution.
 
 Or, equivalently, you can think of the derived shadows as implementing
-the "model": an non-idempotent but no-occurs-check substitution,
+the "model": a non-idempotent but no-occurs-check substitution,
 reflecting *all* *Nominal* equalities (a ~N ty) that are not
 immediately soluble by unification.
 
@@ -1112,8 +1163,78 @@ work?
   because even tyvars in the casts and coercions could give
   an infinite loop if we don't expose it
 
+* CIrredCan: Yes if the inert set can rewrite the constraint.
+  We used to think splitting irreds was unnecessary, but
+  see Note [Splitting Irred WD constraints]
+
 * Others: nothing is gained by splitting.
 
+Note [Splitting Irred WD constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Splitting Irred constraints can make a difference. Here is the
+scenario:
+
+  a[sk] :: F v     -- F is a type family
+  beta :: alpha
+
+  work item: [WD] a ~ beta
+
+This is heterogeneous, so we try flattening the kinds.
+
+  co :: F v ~ fmv
+  [WD] (a |> co) ~ beta
+
+This is still hetero, so we emit a kind equality and make the work item an
+inert Irred.
+
+  work item: [D] fmv ~ alpha
+  inert: [WD] (a |> co) ~ beta (CIrredCan)
+
+Can't make progress on the work item. Add to inert set. This kicks out the
+old inert, because a [D] can rewrite a [WD].
+
+  work item: [WD] (a |> co) ~ beta
+  inert: [D] fmv ~ alpha (CTyEqCan)
+
+Can't make progress on this work item either (although GHC tries by
+decomposing the cast and reflattening... but that doesn't make a difference),
+which is still hetero. Emit a new kind equality and add to inert set. But,
+critically, we split the Irred.
+
+  work list:
+   [D] fmv ~ alpha (CTyEqCan)
+   [D] (a |> co) ~ beta (CIrred) -- this one was split off
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We quickly solve the first work item, as it's the same as an inert.
+
+  work item: [D] (a |> co) ~ beta
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We decompose the cast, yielding
+
+  [D] a ~ beta
+
+We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
+then rewrites to alpha.
+
+  co' :: F v ~ alpha
+  [D] (a |> co') ~ beta
+
+Now this equality is homo-kinded. So we swizzle it around to
+
+  [D] beta ~ (a |> co')
+
+and set beta := a |> co', and go home happy.
+
+If we don't split the Irreds, we loop. This is all dangerously subtle.
+
+This is triggered by test case typecheck/should_compile/SplitWD.
+
 Note [Examples of how Derived shadows helps completeness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Trac #10009, a very nasty example:
@@ -1270,22 +1391,34 @@ shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
     -- NB True: ignore coercions
     -- See Note [Splitting WD constraints]
 
-shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty })
+shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
+                                  , cc_eq_rel = eq_rel })
   =  tv `elemDVarEnv` inert_eqs
-  || anyRewritableTyVar False (`elemDVarEnv` inert_eqs) ty
+  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
   -- NB False: do not ignore casts and coercions
   -- See Note [Splitting WD constraints]
 
+shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
+  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
+
 shouldSplitWD _ _ = False   -- No point in splitting otherwise
 
 should_split_match_args :: InertEqs -> [TcType] -> Bool
 -- True if the inert_eqs can rewrite anything in the argument
 -- types, ignoring casts and coercions
 should_split_match_args inert_eqs tys
-  = any (anyRewritableTyVar True (`elemDVarEnv` inert_eqs)) tys
+  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
     -- NB True: ignore casts coercions
     -- See Note [Splitting WD constraints]
 
+canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
+canRewriteTv inert_eqs eq_rel tv
+  | Just (ct : _) <- lookupDVarEnv inert_eqs tv
+  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct
+  = eq_rel1 `eqCanRewrite` eq_rel
+  | otherwise
+  = False
+
 isImprovable :: CtEvidence -> Bool
 -- See Note [Do not do improvement for WOnly]
 isImprovable (CtWanted { ctev_nosh = WOnly }) = False
@@ -1348,6 +1481,45 @@ equalities arising from injectivity.
 
 {- *********************************************************************
 *                                                                      *
+                   Inert instances: inert_insts
+*                                                                      *
+********************************************************************* -}
+
+addInertForAll :: QCInst -> TcS ()
+-- Add a local Given instance, typically arising from a type signature
+addInertForAll new_qci
+  = updInertCans $ \ics ->
+    ics { inert_insts = add_qci (inert_insts ics) }
+  where
+    add_qci :: [QCInst] -> [QCInst]
+    -- See Note [Do not add duplicate quantified instances]
+    add_qci qcis | any same_qci qcis = qcis
+                 | otherwise         = new_qci : qcis
+
+    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))
+                                (ctEvPred (qci_ev new_qci))
+
+{- Note [Do not add duplicate quantified instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #15244):
+
+  f :: (C g, D g) => ....
+  class S g => C g where ...
+  class S g => D g where ...
+  class (forall a. Eq a => Eq (g a)) => S g where ...
+
+Then in f's RHS there are two identical quantified constraints
+available, one via the superclasses of C and one via the superclasses
+of D.  The two are identical, and it seems wrong to reject the program
+because of that. But without doing duplicate-elimination we will have
+two matching QCInsts when we try to solve constraints arising from f's
+RHS.
+
+The simplest thing is simply to eliminate duplicattes, which we do here.
+-}
+
+{- *********************************************************************
+*                                                                      *
                   Adding an inert
 *                                                                      *
 ************************************************************************
@@ -1386,50 +1558,43 @@ So in kickOutRewritable we look at all the tyvars of the
 CFunEqCan, including the fsk.
 -}
 
-addInertEq :: Ct -> TcS ()
--- This is a key function, because of the kick-out stuff
+addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities
 -- Precondition: item /is/ canonical
 -- See Note [Adding an equality to the InertCans]
-addInertEq ct
-  = do { traceTcS "addInertEq {" $
-         text "Adding new inert equality:" <+> ppr ct
-
-       ; ics <- getInertCans
-
-       ; ct@(CTyEqCan { cc_tyvar = tv, cc_ev = ev }) <- maybeEmitShadow ics ct
-
-       ; (_, ics1) <- kickOutRewritable (ctEvFlavourRole ev) tv ics
-
-       ; let ics2 = ics1 { inert_eqs   = addTyEq (inert_eqs ics1) tv ct
-                         , inert_count = bumpUnsolvedCount ev (inert_count ics1) }
-       ; setInertCans ics2
-
-       ; traceTcS "addInertEq }" $ empty }
-
---------------
-addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities
 addInertCan ct
   = do { traceTcS "insertInertCan {" $
-         text "Trying to insert new non-eq inert item:" <+> ppr ct
+         text "Trying to insert new inert item:" <+> ppr ct
 
        ; ics <- getInertCans
-       ; ct <- maybeEmitShadow ics ct
+       ; ct  <- maybeEmitShadow ics ct
+       ; ics <- maybeKickOut ics ct
        ; setInertCans (add_item ics ct)
 
        ; traceTcS "addInertCan }" $ empty }
 
+maybeKickOut :: InertCans -> Ct -> TcS InertCans
+-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan
+maybeKickOut ics ct
+  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
+       ; return ics' }
+  | otherwise
+  = return ics
+
 add_item :: InertCans -> Ct -> InertCans
 add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
   = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
 
-add_item ics item@(CIrredEvCan { cc_ev = ev })
-  = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item
+add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })
+  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item
         , inert_count = bumpUnsolvedCount ev (inert_count ics) }
-       -- The 'False' is because the irreducible constraint might later instantiate
-       -- to an equality.
-       -- But since we try to simplify first, if there's a constraint function FC with
-       --    type instance FC Int = Show
-       -- we'll reduce a constraint (FC Int a) to Show a, and never add an inert irreducible
+
+add_item ics@(IC { inert_irreds = irreds, inert_count = count })
+         item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })
+  = ics { inert_irreds = irreds `Bag.snocBag` item
+        , inert_count  = if insoluble
+                         then count  -- inert_count does not include insolubles
+                         else bumpUnsolvedCount ev count }
 
 add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
   = ics { inert_dicts = addDict (inert_dicts ics) cls tys item
@@ -1437,9 +1602,8 @@ add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
 
 add_item _ item
   = pprPanic "upd_inert set: can't happen! Inserting " $
-    ppr item   -- CTyEqCan is dealt with by addInertEq
-               -- Can't be CNonCanonical, CHoleCan,
-               -- because they only land in inert_insols
+    ppr item   -- Can't be CNonCanonical, CHoleCan,
+               -- because they only land in inert_irreds
 
 bumpUnsolvedCount :: CtEvidence -> Int -> Int
 bumpUnsolvedCount ev n | isWanted ev = n+1
@@ -1472,13 +1636,14 @@ kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that
                     -> InertCans
                     -> (WorkList, InertCans)
 -- See Note [kickOutRewritable]
-kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs      = tv_eqs
-                                        , inert_dicts    = dictmap
-                                        , inert_safehask = safehask
-                                        , inert_funeqs   = funeqmap
-                                        , inert_irreds   = irreds
-                                        , inert_insols   = insols
-                                        , inert_count    = n })
+kick_out_rewritable new_fr new_tv
+                    ics@(IC { inert_eqs      = tv_eqs
+                            , inert_dicts    = dictmap
+                            , inert_safehask = safehask
+                            , inert_funeqs   = funeqmap
+                            , inert_irreds   = irreds
+                            , inert_insts    = old_insts
+                            , inert_count    = n })
   | not (new_fr `eqMayRewriteFR` new_fr)
   = (emptyWorkList, ics)
         -- If new_fr can't rewrite itself, it can't rewrite
@@ -1494,23 +1659,55 @@ kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs      = tv_eqs
                        , inert_safehask = safehask   -- ??
                        , inert_funeqs   = feqs_in
                        , inert_irreds   = irs_in
-                       , inert_insols   = insols_in
+                       , inert_insts    = insts_in
                        , inert_count    = n - workListWantedCount kicked_out }
 
-    kicked_out = WL { wl_eqs    = tv_eqs_out
-                    , wl_funeqs = feqs_out
-                    , wl_deriv  = []
-                    , wl_rest   = bagToList (dicts_out `andCts` irs_out
-                                             `andCts` insols_out)
-                    , wl_implics = emptyBag }
+    kicked_out :: WorkList
+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority
+    -- See Note [Prioritise equality constraints] (Kick-out).
+    -- The irreds may include non-canonical (hetero-kinded) equality
+    -- constraints, which perhaps may have become soluble after new_tv
+    -- is substituted; ditto the dictionaries, which may include (a~b)
+    -- or (a~~b) constraints.
+    kicked_out = foldrBag extendWorkListCt
+                          (emptyWorkList { wl_eqs    = tv_eqs_out
+                                         , wl_funeqs = feqs_out })
+                          ((dicts_out `andCts` irs_out)
+                            `extendCtsList` insts_out)
 
     (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
     (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap
            -- See Note [Kicking out CFunEqCan for fundeps]
     (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap
     (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds
-    (insols_out, insols_in) = partitionBag     kick_out_ct insols
       -- Kick out even insolubles: See Note [Rewrite insolubles]
+      -- Of course we must kick out irreducibles like (c a), in case
+      -- we can rewrite 'c' to something more useful
+
+    -- Kick-out for inert instances
+    -- See Note [Quantified constraints] in TcCanonical
+    insts_out :: [Ct]
+    insts_in  :: [QCInst]
+    (insts_out, insts_in)
+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens
+       = partitionWith kick_out_qci old_insts
+       | otherwise
+       = ([], old_insts)
+    kick_out_qci qci
+      | let ev = qci_ev qci
+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))
+      = Left (mkNonCanonical ev)
+      | otherwise
+      = Right qci
+
+    (_, new_role) = new_fr
+
+    fr_can_rewrite_ty :: EqRel -> Type -> Bool
+    fr_can_rewrite_ty role ty = anyRewritableTyVar False role
+                                                   fr_can_rewrite_tv ty
+    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
+    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
+                             && tv == new_tv
 
     fr_may_rewrite :: CtFlavourRole -> Bool
     fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
@@ -1519,9 +1716,9 @@ kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs      = tv_eqs
     kick_out_ct :: Ct -> Bool
     -- Kick it out if the new CTyEqCan can rewrite the inert one
     -- See Note [kickOutRewritable]
-    kick_out_ct ct | let ev = ctEvidence ct
-                   = fr_may_rewrite (ctEvFlavourRole ev)
-                   && anyRewritableTyVar False (== new_tv) (ctEvPred ev)
+    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct
+                   = fr_may_rewrite fs
+                   && fr_can_rewrite_ty role (ctPred ct)
                   -- False: ignore casts and coercions
                   -- NB: this includes the fsk of a CFunEqCan.  It can't
                   --     actually be rewritten, but we need to kick it out
@@ -1535,33 +1732,34 @@ kick_out_rewritable new_fr new_tv ics@(IC { inert_eqs      = tv_eqs
                                []      -> acc_in
                                (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
       where
-        (eqs_in, eqs_out) = partition keep_eq eqs
+        (eqs_out, eqs_in) = partition kick_out_eq eqs
 
     -- Implements criteria K1-K3 in Note [Extending the inert equalities]
-    keep_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty, cc_ev = ev
-                      , cc_eq_rel = eq_rel })
-      | tv == new_tv
-      = not (fr_may_rewrite fs)  -- (K1)
+    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
+                          , cc_ev = ev, cc_eq_rel = eq_rel })
+      | not (fr_may_rewrite fs)
+      = False  -- Keep it in the inert set if the new thing can't rewrite it
+
+      -- Below here (fr_may_rewrite fs) is True
+      | tv == new_tv              = True        -- (K1)
+      | kick_out_for_inertness    = True
+      | kick_out_for_completeness = True
+      | otherwise                 = False
 
-      | otherwise
-      = check_k2 && check_k3
       where
-        fs = ctEvFlavourRole ev
-        check_k2 = not (fs  `eqMayRewriteFR` fs)                   -- (K2a)
-                ||     (fs  `eqMayRewriteFR` new_fr)               -- (K2b)
-                || not (fr_may_rewrite  fs)                        -- (K2c)
-                || not (new_tv `elemVarSet` tyCoVarsOfType rhs_ty) -- (K2d)
-
-        check_k3
-          | fr_may_rewrite fs
+        fs = (ctEvFlavour ev, eq_rel)
+        kick_out_for_inertness
+          =        (fs `eqMayRewriteFR` fs)       -- (K2a)
+            && not (fs `eqMayRewriteFR` new_fr)   -- (K2b)
+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)
+            -- (K2c) is guaranteed by the first guard of keep_eq
+
+        kick_out_for_completeness
           = case eq_rel of
-              NomEq  -> not (rhs_ty `eqType` mkTyVarTy new_tv)
-              ReprEq -> not (isTyVarExposed new_tv rhs_ty)
+              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv
+              ReprEq -> isTyVarHead new_tv rhs_ty
 
-          | otherwise
-          = True
-
-    keep_eq ct = pprPanic "keep_eq" (ppr ct)
+    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
 
 kickOutAfterUnification :: TcTyVar -> TcS Int
 kickOutAfterUnification new_tv
@@ -1660,6 +1858,15 @@ addSolvedDict item cls tys
        ; updInertTcS $ \ ics ->
              ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
 
+getSolvedDicts :: TcS (DictMap CtEvidence)
+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }
+
+setSolvedDicts :: DictMap CtEvidence -> TcS ()
+setSolvedDicts solved_dicts
+  = updInertTcS $ \ ics ->
+    ics { inert_solved_dicts = solved_dicts }
+
+
 {- *********************************************************************
 *                                                                      *
                   Other inert-set operations
@@ -1717,7 +1924,10 @@ getInertEqs :: TcS (DTyVarEnv EqualCtList)
 getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
 
 getInertInsols :: TcS Cts
-getInertInsols = do { inert <- getInertCans; return (inert_insols inert) }
+-- Returns insoluble equality constraints
+-- specifically including Givens
+getInertInsols = do { inert <- getInertCans
+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }
 
 getInertGivens :: TcS [Ct]
 -- Returns the Given constraints in the inert set,
@@ -1729,34 +1939,57 @@ getInertGivens
                      $ concat (dVarEnvElts (inert_eqs inerts))
        ; return (filter isGivenCt all_cts) }
 
-getPendingScDicts :: TcS [Ct]
--- Find all inert Given dictionaries whose cc_pend_sc flag is True
--- Set the flag to False in the inert set, and return that Ct
-getPendingScDicts = updRetInertCans get_sc_dicts
+getPendingGivenScs :: TcS [Ct]
+-- Find all inert Given dictionaries, or quantified constraints,
+--     whose cc_pend_sc flag is True
+--     and that belong to the current level
+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+getPendingGivenScs = do { lvl <- getTcLevel
+                        ; updRetInertCans (get_sc_pending lvl) }
+
+get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
+  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )
+       -- When getPendingScDics is called,
+       -- there are never any Wanteds in the inert set
+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
   where
-    get_sc_dicts ic@(IC { inert_dicts = dicts })
-      = (sc_pend_dicts, ic')
-      where
-        ic' = ic { inert_dicts = foldr add dicts sc_pend_dicts }
+    sc_pending = sc_pend_insts ++ sc_pend_dicts
 
-        sc_pend_dicts :: [Ct]
-        sc_pend_dicts = foldDicts get_pending dicts []
+    sc_pend_dicts = foldDicts get_pending dicts []
+    dicts' = foldr add dicts sc_pend_dicts
+
+    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
 
     get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True
                                        -- but flipping the flag
     get_pending dict dicts
-        | Just dict' <- isPendingScDict dict = dict' : dicts
-        | otherwise                          = dicts
+        | Just dict' <- isPendingScDict dict
+        , belongs_to_this_level (ctEvidence dict)
+        = dict' : dicts
+        | otherwise
+        = dicts
 
     add :: Ct -> DictMap Ct -> DictMap Ct
     add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
         = addDict dicts cls tys ct
     add ct _ = pprPanic "getPendingScDicts" (ppr ct)
 
+    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
+    get_pending_inst cts qci@(QCI { qci_ev = ev })
+       | Just qci' <- isPendingScInst qci
+       , belongs_to_this_level ev
+       = (CQuantCan qci' : cts, qci')
+       | otherwise
+       = (cts, qci)
+
+    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
+    -- We only want Givens from this level; see (3a) in
+    -- Note [The superclass story] in TcCanonical
+
 getUnsolvedInerts :: TcS ( Bag Implication
                          , Cts     -- Tyvar eqs: a ~ ty
                          , Cts     -- Fun eqs:   F a ~ ty
-                         , Cts     -- Insoluble
                          , Cts )   -- All others
 -- Return all the unsolved [Wanted] or [Derived] constraints
 --
@@ -1768,7 +2001,6 @@ getUnsolvedInerts
            , inert_funeqs = fun_eqs
            , inert_irreds = irreds
            , inert_dicts  = idicts
-           , inert_insols = insols
            } <- getInertCans
 
       ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
@@ -1776,19 +2008,16 @@ getUnsolvedInerts
             unsolved_irreds  = Bag.filterBag is_unsolved irreds
             unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
             unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts
-            unsolved_insols  = filterBag is_unsolved insols
 
       ; implics <- getWorkListImplics
 
       ; traceTcS "getUnsolvedInerts" $
         vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
              , text "fun eqs =" <+> ppr unsolved_fun_eqs
-             , text "insols =" <+> ppr unsolved_insols
              , text "others =" <+> ppr unsolved_others
              , text "implics =" <+> ppr implics ]
 
-      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs
-               , unsolved_insols, unsolved_others) }
+      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
   where
     add_if_unsolved :: Ct -> Cts -> Cts
     add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
@@ -1799,7 +2028,7 @@ getUnsolvedInerts
     -- For CFunEqCans we ignore the Derived ones, and keep
     -- only the Wanteds for flattening.  The Derived ones
     -- share a unification variable with the corresponding
-    -- Wanted, so we definitely don't want to to participate
+    -- Wanted, so we definitely don't want to participate
     -- in unflattening
     -- See Note [Type family equations]
     add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts
@@ -1821,32 +2050,39 @@ isInInertEqs eqs tv rhs
 getNoGivenEqs :: TcLevel          -- TcLevel of this implication
                -> [TcTyVar]       -- Skolems of this implication
                -> TcS ( Bool      -- True <=> definitely no residual given equalities
-                      , Cts )     -- Insoluble constraints arising from givens
+                      , Cts )     -- Insoluble equalities arising from givens
 -- See Note [When does an implication have given equalities?]
 getNoGivenEqs tclvl skol_tvs
-  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds
-                    , inert_insols = insols })
+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
               <- getInertCans
-       ; let has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False
-                                      (iirreds `unionBags` insols)
+       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds
                           || anyDVarEnv eqs_given_here ieqs
-
-       ; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts
-                                        , ppr insols])
+             insols = filterBag insolubleEqCt irreds
+                      -- Specifically includes ones that originated in some
+                      -- outer context but were refined to an insoluble by
+                      -- a local equality; so do /not/ add ct_given_here.
+
+       ; traceTcS "getNoGivenEqs" $
+         vcat [ if has_given_eqs then text "May have given equalities"
+                                 else text "No given equalities"
+              , text "Skols:" <+> ppr skol_tvs
+              , text "Inerts:" <+> ppr inerts
+              , text "Insols:" <+> ppr insols]
        ; return (not has_given_eqs, insols) }
   where
     eqs_given_here :: EqualCtList -> Bool
-    eqs_given_here [CTyEqCan { cc_tyvar = tv, cc_ev = ev }]
+    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
                               -- Givens are always a sigleton
-      = not (skolem_bound_here tv) && ev_given_here ev
+      = not (skolem_bound_here tv) && ct_given_here ct
     eqs_given_here _ = False
 
-    ev_given_here :: CtEvidence -> Bool
+    ct_given_here :: Ct -> Bool
     -- True for a Given bound by the current implication,
     -- i.e. the current level
-    ev_given_here ev
-      =  isGiven ev
-      && tclvl == ctLocLevel (ctEvLoc ev)
+    ct_given_here ct =  isGiven ev
+                     && tclvl == ctLocLevel (ctEvLoc ev)
+        where
+          ev = ctEvidence ct
 
     skol_tv_set = mkVarSet skol_tvs
     skolem_bound_here tv -- See Note [Let-bound skolems]
@@ -1859,7 +2095,7 @@ getNoGivenEqs tclvl skol_tvs
 -- Given might overlap with an instance. See Note [Instance and Given overlap]
 -- in TcInteract.
 matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
-matchableGivens loc_w pred (IS { inert_cans = inert_cans })
+matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })
   = filterBag matchable_given all_relevant_givens
   where
     -- just look in class constraints and irreds. matchableGivens does get called
@@ -1868,7 +2104,7 @@ matchableGivens loc_w pred (IS { inert_cans = inert_cans })
     -- non-canonical -- that is, irreducible -- equalities.
     all_relevant_givens :: Cts
     all_relevant_givens
-      | Just (clas, _) <- getClassPredTys_maybe pred
+      | Just (clas, _) <- getClassPredTys_maybe pred_w
       = findDictsByClass (inert_dicts inert_cans) clas
         `unionBags` inert_irreds inert_cans
       | otherwise
@@ -1876,16 +2112,17 @@ matchableGivens loc_w pred (IS { inert_cans = inert_cans })
 
     matchable_given :: Ct -> Bool
     matchable_given ct
-      | CtGiven { ctev_loc = loc_g } <- ctev
-      , Just _ <- tcUnifyTys bind_meta_tv [ctEvPred ctev] [pred]
-      , not (prohibitedSuperClassSolve loc_g loc_w)
-      = True
+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct
+      = mightMatchLater pred_g loc_g pred_w loc_w
 
       | otherwise
       = False
-      where
-        ctev = cc_ev ct
 
+mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
+mightMatchLater given_pred given_loc wanted_pred wanted_loc
+  =  not (prohibitedSuperClassSolve given_loc wanted_loc)
+  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])
+  where
     bind_meta_tv :: TcTyVar -> BindFlag
     -- Any meta tyvar may be unified later, so we treat it as
     -- bindable when unifying with givens. That ensures that we
@@ -1959,7 +2196,7 @@ are some wrinkles:
 Note [Let-bound skolems]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)
-and  * 'a' is a skolem bound in this very implication, b
+and  * 'a' is a skolem bound in this very implication,
 
 then:
 a) The Given is pretty much a let-binding, like
@@ -1974,6 +2211,10 @@ b) 'a' will have been completely substituted out in the inert set,
    returned as part of 'fsks'
 
 For an example, see Trac #9211.
+
+See also TcUnify Note [Deeper level on the left] for how we ensure
+that the right variable is on the left of the equality when both are
+tyvars.
 -}
 
 removeInertCts :: [Ct] -> InertCans -> InertCans
@@ -1994,7 +2235,8 @@ removeInertCt is ct =
     CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->
       is { inert_eqs    = delTyEq (inert_eqs is) x ty }
 
-    CIrredEvCan {}   -> panic "removeInertCt: CIrredEvCan"
+    CQuantCan {}     -> panic "removeInertCt: CQuantCan"
+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"
     CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
     CHoleCan {}      -> panic "removeInertCt: CHoleCan"
 
@@ -2017,30 +2259,30 @@ lookupFlatCache fam_tc tys
     lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
 
 
-lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence)
+lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
 -- Is this exact predicate type cached in the solved or canonicals of the InertSet?
-lookupInInerts pty
+lookupInInerts loc pty
   | ClassPred cls tys <- classifyPredType pty
   = do { inerts <- getTcSInerts
-       ; return (lookupSolvedDict inerts cls tys `mplus`
-                 lookupInertDict (inert_cans inerts) cls tys) }
+       ; return (lookupSolvedDict inerts loc cls tys `mplus`
+                 lookupInertDict (inert_cans inerts) loc cls tys) }
   | otherwise -- NB: No caching for equalities, IPs, holes, or errors
   = return Nothing
 
 -- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not
 -- match the input exactly. Note [Use loose types in inert set].
-lookupInertDict :: InertCans -> Class -> [Type] -> Maybe CtEvidence
-lookupInertDict (IC { inert_dicts = dicts }) cls tys
-  = case findDict dicts cls tys of
+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
+  = case findDict dicts loc cls tys of
       Just ct -> Just (ctEvidence ct)
       _       -> Nothing
 
 -- | Look up a solved inert. NB: the returned 'CtEvidence' might not
 -- match the input exactly. See Note [Use loose types in inert set].
-lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence
+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
 -- Returns just if exactly this predicate type exists in the solved.
-lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys
-  = case findDict solved cls tys of
+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
+  = case findDict solved loc cls tys of
       Just ev -> Just ev
       _       -> Nothing
 
@@ -2067,7 +2309,7 @@ solvable from the other. So, we do lookup in the inert set using
 loose types, which omit the kind-check.
 
 We must be careful when using the result of a lookup because it may
-not match the requsted info exactly!
+not match the requested info exactly!
 
 -}
 
@@ -2127,16 +2369,66 @@ foldTcAppMap k m z = foldUDFM (foldTM k) z m
 *                                                                      *
 ********************************************************************* -}
 
+
+{- Note [Tuples hiding implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f,g :: (?x::Int, C a) => a -> a
+   f v = let ?x = 4 in g v
+
+The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).
+We must /not/ solve this from the Given (?x::Int, C a), because of
+the intervening binding for (?x::Int).  Trac #14218.
+
+We deal with this by arranging that we always fail when looking up a
+tuple constraint that hides an implicit parameter. Not that this applies
+  * both to the inert_dicts (lookupInertDict)
+  * and to the solved_dicts (looukpSolvedDict)
+An alternative would be not to extend these sets with such tuple
+constraints, but it seemed more direct to deal with the lookup.
+
+Note [Solving CallStack constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose f :: HasCallStack => blah.  Then
+
+* Each call to 'f' gives rise to
+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f
+  with a CtOrigin that says "OccurrenceOf f".
+  Remember that HasCallStack is just shorthand for
+    IP "callStack CallStack
+  See Note [Overview of implicit CallStacks] in TcEvidence
+
+* We cannonicalise such constraints, in TcCanonical.canClassNC, by
+  pushing the call-site info on the stack, and changing the CtOrigin
+  to record that has been done.
+   Bind:  s1 = pushCallStack <site-info> s2
+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin
+
+* Then, and only then, we can solve the constraint from an enclosing
+  Given.
+
+So we must be careful /not/ to solve 's1' from the Givens.  Again,
+we ensure this by arranging that findDict always misses when looking
+up souch constraints.
+-}
+
 type DictMap a = TcAppMap a
 
 emptyDictMap :: DictMap a
 emptyDictMap = emptyTcAppMap
 
--- sizeDictMap :: DictMap a -> Int
--- sizeDictMap m = foldDicts (\ _ x -> x+1) m 0
+findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
+findDict m loc cls tys
+  | isCTupleClass cls
+  , any hasIPPred tys   -- See Note [Tuples hiding implicit parameters]
+  = Nothing
 
-findDict :: DictMap a -> Class -> [Type] -> Maybe a
-findDict m cls tys = findTcApp m (getUnique cls) tys
+  | Just {} <- isCallStackPred cls tys
+  , OccurrenceOf {} <- ctLocOrigin loc
+  = Nothing             -- See Note [Solving CallStack constraints]
+
+  | otherwise
+  = findTcApp m (getUnique cls) tys
 
 findDictsByClass :: DictMap a -> Class -> Bag a
 findDictsByClass m cls
@@ -2295,17 +2587,21 @@ instance Applicative TcS where
   (<*>) = ap
 
 instance Monad TcS where
-  fail err  = TcS (\_ -> fail err)
+  fail = MonadFail.fail
   m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail TcS where
   fail err  = TcS (\_ -> fail err)
-#endif
 
 instance MonadUnique TcS where
    getUniqueSupplyM = wrapTcS getUniqueSupplyM
 
+instance HasModule TcS where
+   getModule = wrapTcS getModule
+
+instance MonadThings TcS where
+   lookupThing n = wrapTcS (lookupThing n)
+
 -- Basic functionality
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 wrapTcS :: TcM a -> TcS a
@@ -2393,7 +2689,7 @@ runTcSDeriveds tcs
 -- | This can deal only with equality constraints.
 runTcSEqualities :: TcS a -> TcM a
 runTcSEqualities thing_inside
-  = do { ev_binds_var <- TcM.newTcEvBinds
+  = do { ev_binds_var <- TcM.newNoTcEvBinds
        ; runTcSWithEvBinds ev_binds_var thing_inside }
 
 runTcSWithEvBinds :: EvBindsVar
@@ -2468,9 +2764,10 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
                    , tcs_count         = count
                    } ->
     do { inerts <- TcM.readTcRef old_inert_var
-       ; let nest_inert = emptyInert { inert_cans         = inert_cans inerts
-                                     , inert_solved_dicts = inert_solved_dicts inerts }
-                          -- See Note [Do not inherit the flat cache]
+       ; let nest_inert = emptyInert
+                            { inert_cans = inert_cans inerts
+                            , inert_solved_dicts = inert_solved_dicts inerts }
+                              -- See Note [Do not inherit the flat cache]
        ; new_inert_var <- TcM.newTcRef nest_inert
        ; new_wl_var    <- TcM.newTcRef emptyWorkList
        ; let nest_env = TcSEnv { tcs_ev_binds      = ref
@@ -2530,44 +2827,81 @@ nestTcS (TcS thing_inside)
 
        ; return res }
 
-buildImplication :: SkolemInfo
-                 -> [TcTyVar]        -- Skolems
-                 -> [EvVar]          -- Givens
-                 -> TcS result
-                 -> TcS (Bag Implication, TcEvBinds, result)
--- Just like TcUnify.buildImplication, but in the TcS monnad,
--- using the work-list to gather the constraints
-buildImplication skol_info skol_tvs givens (TcS thing_inside)
-  = TcS $ \ env ->
-    do { new_wl_var <- TcM.newTcRef emptyWorkList
-       ; tc_lvl <- TcM.getTcLevel
-       ; let new_tclvl = pushTcLevel tc_lvl
-
-       ; res <- TcM.setTcLevel new_tclvl $
-                thing_inside (env { tcs_worklist = new_wl_var })
-
-       ; wl@WL { wl_eqs = eqs } <- TcM.readTcRef new_wl_var
-       ; if null eqs
-         then return (emptyBag, emptyTcEvBinds, res)
-         else
-    do { env <- TcM.getLclEnv
+checkTvConstraintsTcS :: SkolemInfo
+                      -> [TcTyVar]        -- Skolems
+                      -> TcS (result, Cts)
+                      -> TcS result
+-- Just like TcUnify.checkTvConstraints, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - No 'givens', and no TcEvBinds; this is type-level constraints only
+checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
+       ; unless (null wanteds) $
+         do { ev_binds_var <- TcM.newNoTcEvBinds
+            ; imp <- newImplication
+            ; let wc = emptyWC { wc_simple = wanteds }
+                  imp' = imp { ic_tclvl  = new_tclvl
+                             , ic_skols  = skol_tvs
+                             , ic_wanted = wc
+                             , ic_binds  = ev_binds_var
+                             , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+           ; TcM.updTcRef (tcs_worklist tcs_env)
+                          (extendWorkListImplic (unitBag imp')) }
+
+      ; return res }
+
+checkConstraintsTcS :: SkolemInfo
+                    -> [TcTyVar]        -- Skolems
+                    -> [EvVar]          -- Givens
+                    -> TcS (result, Cts)
+                    -> TcS (result, TcEvBinds)
+-- Just like checkConstraintsTcS, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - I did not bother to put in the fast-path for
+--     empty-skols/empty-givens, or for empty-wanteds, because
+--     this function is used only for "quantified constraints" in
+--     with both tests are pretty much guaranteed to fail
+checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
        ; ev_binds_var <- TcM.newTcEvBinds
-       ; let wc  = ASSERT2( null (wl_funeqs wl) && null (wl_rest wl) &&
-                            null (wl_deriv wl) && null (wl_implics wl), ppr wl )
-                   WC { wc_simple = listToCts eqs
-                      , wc_impl   = emptyBag
-                      , wc_insol  = emptyCts }
-             imp = Implic { ic_tclvl  = new_tclvl
-                          , ic_skols  = skol_tvs
-                          , ic_no_eqs = True
-                          , ic_given  = givens
-                          , ic_wanted = wc
-                          , ic_status = IC_Unsolved
-                          , ic_binds  = ev_binds_var
-                          , ic_env    = env
-                          , ic_needed = emptyVarSet
-                          , ic_info   = skol_info }
-      ; return (unitBag imp, TcEvBinds ev_binds_var, res) } }
+       ; imp <- newImplication
+       ; let wc = emptyWC { wc_simple = wanteds }
+             imp' = imp { ic_tclvl  = new_tclvl
+                        , ic_skols  = skol_tvs
+                        , ic_given  = given
+                        , ic_wanted = wc
+                        , ic_binds  = ev_binds_var
+                        , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+       ; TcM.updTcRef (tcs_worklist tcs_env)
+                      (extendWorkListImplic (unitBag imp'))
+
+       ; return (res, TcEvBinds ev_binds_var) }
 
 {-
 Note [Propagate the solved dictionaries]
@@ -2594,23 +2928,21 @@ getTcSWorkListRef :: TcS (IORef WorkList)
 getTcSWorkListRef = TcS (return . tcs_worklist)
 
 getTcSInerts :: TcS InertSet
-getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
+getTcSInerts = getTcSInertsRef >>= readTcRef
 
 setTcSInerts :: InertSet -> TcS ()
-setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) }
+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }
 
 getWorkListImplics :: TcS (Bag Implication)
 getWorkListImplics
   = do { wl_var <- getTcSWorkListRef
-       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
+       ; wl_curr <- readTcRef wl_var
        ; return (wl_implics wl_curr) }
 
 updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
 updWorkListTcS f
   = do { wl_var <- getTcSWorkListRef
-       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
-       ; let new_work = f wl_curr
-       ; wrapTcS (TcM.writeTcRef wl_var new_work) }
+       ; updTcRef wl_var f }
 
 emitWorkNC :: [CtEvidence] -> TcS ()
 emitWorkNC evs
@@ -2624,27 +2956,15 @@ emitWork cts
   = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
        ; updWorkListTcS (extendWorkListCts cts) }
 
-emitInsoluble :: Ct -> TcS ()
--- Emits a non-canonical constraint that will stand for a frozen error in the inerts.
-emitInsoluble ct
-  = do { traceTcS "Emit insoluble" (ppr ct $$ pprCtLoc (ctLoc ct))
-       ; updInertTcS add_insol }
-  where
-    this_pred = ctPred ct
-    add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })
-      | drop_it   = is
-      | otherwise = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } }
-      where
-        drop_it = isDroppableDerivedCt ct &&
-                  anyBag (tcEqType this_pred . ctPred) old_insols
-             -- See Note [Do not add duplicate derived insolubles]
-
 newTcRef :: a -> TcS (TcRef a)
 newTcRef x = wrapTcS (TcM.newTcRef x)
 
 readTcRef :: TcRef a -> TcS a
 readTcRef ref = wrapTcS (TcM.readTcRef ref)
 
+writeTcRef :: TcRef a -> a -> TcS ()
+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)
+
 updTcRef :: TcRef a -> (a->a) -> TcS ()
 updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
 
@@ -2654,16 +2974,17 @@ getTcEvBindsVar = TcS (return . tcs_ev_binds)
 getTcLevel :: TcS TcLevel
 getTcLevel = wrapTcS TcM.getTcLevel
 
-getTcEvBindsAndTCVs :: EvBindsVar -> TcS (EvBindMap, TyCoVarSet)
-getTcEvBindsAndTCVs ev_binds_var
-  = wrapTcS $ do { bnds <- TcM.getTcEvBindsMap ev_binds_var
-                 ; tcvs <- TcM.getTcEvTyCoVars ev_binds_var
-                 ; return (bnds, tcvs) }
+getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
 
-getTcEvBindsMap :: TcS EvBindMap
-getTcEvBindsMap
-  = do { ev_binds_var <- getTcEvBindsVar
-       ; wrapTcS $ TcM.getTcEvBindsMap ev_binds_var }
+getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
+getTcEvBindsMap ev_binds_var
+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
+setTcEvBindsMap ev_binds_var binds
+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds
 
 unifyTyVar :: TcTyVar -> TcType -> TcS ()
 -- Unify a meta-tyvar with a type
@@ -2726,28 +3047,33 @@ addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-checkWellStagedDFun :: PredType -> DFunId -> CtLoc -> TcS ()
-checkWellStagedDFun pred dfun_id loc
+checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
+-- Check that we do not try to use an instance before it is available.  E.g.
+--    instance Eq T where ...
+--    f x = $( ... (\(p::T) -> p == p)... )
+-- Here we can't use the equality function from the instance in the splice
+
+checkWellStagedDFun loc what pred
+  | TopLevInstance { iw_dfun_id = dfun_id } <- what
+  , let bind_lvl = TcM.topIdLvl dfun_id
+  , bind_lvl > impLevel
   = wrapTcS $ TcM.setCtLocM loc $
     do { use_stage <- TcM.getStage
        ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+
+  | otherwise
+  = return ()    -- Fast path for common case
   where
     pp_thing = text "instance for" <+> quotes (ppr pred)
-    bind_lvl = TcM.topIdLvl dfun_id
 
 pprEq :: TcType -> TcType -> SDoc
 pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
 
-isTouchableMetaTyVarTcS :: TcTyVar -> TcS Bool
-isTouchableMetaTyVarTcS tv
-  = do { tclvl <- getTcLevel
-       ; return $ isTouchableMetaTyVar tclvl tv }
-
 isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
 isFilledMetaTyVar_maybe tv
  = case tcTyVarDetails tv of
      MetaTv { mtv_ref = ref }
-        -> do { cts <- wrapTcS (TcM.readTcRef ref)
+        -> do { cts <- readTcRef ref
               ; case cts of
                   Indirect ty -> return (Just ty)
                   Flexi       -> return Nothing }
@@ -2780,56 +3106,8 @@ zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
 zonkWC :: WantedConstraints -> TcS WantedConstraints
 zonkWC wc = wrapTcS (TcM.zonkWC wc)
 
-{-
-Note [Do not add duplicate derived insolubles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general we *must* add an insoluble (Int ~ Bool) even if there is
-one such there already, because they may come from distinct call
-sites.  Not only do we want an error message for each, but with
--fdefer-type-errors we must generate evidence for each.  But for
-*derived* insolubles, we only want to report each one once.  Why?
-
-(a) A constraint (C r s t) where r -> s, say, may generate the same fundep
-    equality many times, as the original constraint is successively rewritten.
-
-(b) Ditto the successive iterations of the main solver itself, as it traverses
-    the constraint tree. See example below.
-
-Also for *given* insolubles we may get repeated errors, as we
-repeatedly traverse the constraint tree.  These are relatively rare
-anyway, so removing duplicates seems ok.  (Alternatively we could take
-the SrcLoc into account.)
-
-Note that the test does not need to be particularly efficient because
-it is only used if the program has a type error anyway.
-
-Example of (b): assume a top-level class and instance declaration:
-
-  class D a b | a -> b
-  instance D [a] [a]
-
-Assume we have started with an implication:
-
-  forall c. Eq c => { wc_simple = D [c] c [W] }
-
-which we have simplified to:
-
-  forall c. Eq c => { wc_simple = D [c] c [W]
-                    , wc_insols = (c ~ [c]) [D] }
-
-For some reason, e.g. because we floated an equality somewhere else,
-we might try to re-solve this implication. If we do not do a
-dropDerivedWC, then we will end up trying to solve the following
-constraints the second time:
-
-  (D [c] c) [W]
-  (c ~ [c]) [D]
-
-which will result in two Deriveds to end up in the insoluble set:
-
-  wc_simple   = D [c] c [W]
-  wc_insols = (c ~ [c]) [D], (c ~ [c]) [D]
--}
+zonkTcTyCoVarBndr :: TcTyCoVar -> TcS TcTyCoVar
+zonkTcTyCoVarBndr tv = wrapTcS (TcM.zonkTcTyCoVarBndr tv)
 
 {- *********************************************************************
 *                                                                      *
@@ -2858,7 +3136,7 @@ newFlattenSkolem flav loc tc xis
            -- Construct the Refl evidence
            ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
                  co   = mkNomReflCo fam_ty
-           ; ev  <- newGivenEvVar loc (pred, EvCoercion co)
+           ; ev  <- newGivenEvVar loc (pred, evCoercion co)
            ; return (ev, co, fsk) }
 
       | otherwise  -- Generate a [WD] for both Wanted and Derived
@@ -2870,7 +3148,7 @@ newFlattenSkolem flav loc tc xis
 ----------------------------
 unflattenGivens :: IORef InertSet -> TcM ()
 -- Unflatten all the fsks created by flattening types in Given
--- constraints We must be sure to do this, else we end up with
+-- constraints. We must be sure to do this, else we end up with
 -- flatten-skolems buried in any residual Wanteds
 --
 -- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
@@ -2881,6 +3159,7 @@ unflattenGivens :: IORef InertSet -> TcM ()
 -- is nicely paired with the creation an empty inert_fsks list.
 unflattenGivens inert_var
  = do { inerts <- TcM.readTcRef inert_var
+       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
        ; mapM_ flatten_one (inert_fsks inerts) }
   where
     flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty
@@ -2921,6 +3200,51 @@ demoteUnfilledFmv fmv
                    do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
                       ; TcM.writeMetaTyVar fmv tv_ty } }
 
+-----------------------------
+dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
+-- (dischargeFunEq tv co ty)
+--     Preconditions
+--       - ev :: F tys ~ tv   is a CFunEqCan
+--       - tv is a FlatMetaTv of FlatSkolTv
+--       - co :: F tys ~ xi
+--       - fmv/fsk `notElem` xi
+--       - fmv not filled (for Wanteds)
+--
+-- Then for [W] or [WD], we actually fill in the fmv:
+--      set fmv := xi,
+--      set ev  := co
+--      kick out any inert things that are now rewritable
+--
+-- For [D], we instead emit an equality that must ultimately hold
+--      [D] xi ~ fmv
+--      Does not evaluate 'co' if 'ev' is Derived
+--
+-- For [G], emit this equality
+--     [G] (sym ev; co) :: fsk ~ xi
+
+-- See TcFlatten Note [The flattening story],
+-- especially "Ownership of fsk/fmv"
+dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
+  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )
+       ; emitWorkNC [new_ev] }
+  where
+    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
+    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
+
+dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi
+  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
+    do { setWantedEvTerm dest (evCoercion co)
+       ; unflattenFmv fmv xi
+       ; n_kicked <- kickOutAfterUnification fmv
+       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
+
+dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
+  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
+              -- FunEqs are always at Nominal role
+
+pprKicked :: Int -> SDoc
+pprKicked 0 = empty
+pprKicked n = parens (int n <+> text "kicked out")
 
 {- *********************************************************************
 *                                                                      *
@@ -2955,14 +3279,15 @@ instFlexiHelper subst tv
        ; let name = setNameUnique (tyVarName tv) uniq
              kind = substTyUnchecked subst (tyVarKind tv)
              ty'  = mkTyVarTy (mkTcTyVar name kind details)
+       ; TcM.traceTc "instFlexi" (ppr ty')
        ; return (extendTvSubst subst tv ty') }
 
-tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-                   -- ^ How to instantiate the type variables
-           -> Id   -- ^ Type to instantiate
-           -> TcS ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
-                -- (type vars, preds (incl equalities), rho)
-tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id)
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcS TcM.ClsInstResult
+matchGlobalInst dflags short_cut cls tys
+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)
 
 tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])
 tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
@@ -2970,7 +3295,7 @@ tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
 -- Creating and setting evidence variables and CtFlavors
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-data MaybeNew = Fresh CtEvidence | Cached EvTerm
+data MaybeNew = Fresh CtEvidence | Cached EvExpr
 
 isFresh :: MaybeNew -> Bool
 isFresh (Fresh {})  = True
@@ -2979,9 +3304,9 @@ isFresh (Cached {}) = False
 freshGoals :: [MaybeNew] -> [CtEvidence]
 freshGoals mns = [ ctev | Fresh ctev <- mns ]
 
-getEvTerm :: MaybeNew -> EvTerm
-getEvTerm (Fresh ctev) = ctEvTerm ctev
-getEvTerm (Cached evt) = evt
+getEvExpr :: MaybeNew -> EvExpr
+getEvExpr (Fresh ctev) = ctEvExpr ctev
+getEvExpr (Cached evt) = evt
 
 setEvBind :: EvBind -> TcS ()
 setEvBind ev_bind
@@ -2991,7 +3316,8 @@ setEvBind ev_bind
 -- | Mark variables as used filling a coercion hole
 useVars :: CoVarSet -> TcS ()
 useVars vars
-  = do { EvBindsVar { ebv_tcvs = ref } <- getTcEvBindsVar
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; let ref = ebv_tcvs ev_binds_var
        ; wrapTcS $
          do { tcvs <- TcM.readTcRef ref
             ; let tcvs' = tcvs `unionVarSet` vars
@@ -3004,32 +3330,32 @@ setWantedEq (HoleDest hole) co
        ; wrapTcS $ TcM.fillCoercionHole hole co }
 setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)
 
--- | Equalities only
-setEqIfWanted :: CtEvidence -> Coercion -> TcS ()
-setEqIfWanted (CtWanted { ctev_dest = dest }) co = setWantedEq dest co
-setEqIfWanted _ _ = return ()
-
--- | Good for equalities and non-equalities
+-- | Good for both equalities and non-equalities
 setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()
 setWantedEvTerm (HoleDest hole) tm
-  = do { let co = evTermCoercion tm
-       ; useVars (coVarsOfCo co)
+  | Just co <- evTermCoercion_maybe tm
+  = do { useVars (coVarsOfCo co)
        ; wrapTcS $ TcM.fillCoercionHole hole co }
-setWantedEvTerm (EvVarDest ev) tm = setWantedEvBind ev tm
+  | otherwise
+  = do { let co_var = coHoleCoVar hole
+       ; setEvBind (mkWantedEvBind co_var tm)
+       ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }
 
-setWantedEvBind :: EvVar -> EvTerm -> TcS ()
-setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm)
+setWantedEvTerm (EvVarDest ev_id) tm
+  = setEvBind (mkWantedEvBind ev_id tm)
 
 setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
 setEvBindIfWanted ev tm
   = case ev of
-      CtWanted { ctev_dest = dest }
-        -> setWantedEvTerm dest tm
-      _ -> return ()
+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm
+      _                             -> return ()
 
 newTcEvBinds :: TcS EvBindsVar
 newTcEvBinds = wrapTcS TcM.newTcEvBinds
 
+newNoTcEvBinds :: TcS EvBindsVar
+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
+
 newEvVar :: TcPredType -> TcS EvVar
 newEvVar pred = wrapTcS (TcM.newEvVar pred)
 
@@ -3065,12 +3391,12 @@ emitNewWantedEq loc role ty1 ty2
 -- | Make a new equality CtEvidence
 newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)
 newWantedEq loc role ty1 ty2
-  = do { hole <- wrapTcS $ TcM.newCoercionHole
+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty
        ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
        ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
                            , ctev_nosh = WDeriv
                            , ctev_loc = loc}
-                , mkHoleCo hole role ty1 ty2 ) }
+                , mkHoleCo hole ) }
   where
     pty = mkPrimEqPredRole role ty1 ty2
 
@@ -3088,12 +3414,12 @@ newWantedEvVarNC loc pty
 newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
 -- For anything except ClassPred, this is the same as newWantedEvVarNC
 newWantedEvVar loc pty
-  = do { mb_ct <- lookupInInerts pty
+  = do { mb_ct <- lookupInInerts loc pty
        ; case mb_ct of
             Just ctev
               | not (isDerived ctev)
               -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
-                    ; return $ Cached (ctEvTerm ctev) }
+                    ; return $ Cached (ctEvExpr ctev) }
             _ -> do { ctev <- newWantedEvVarNC loc pty
                     ; return (Fresh ctev) } }
 
@@ -3114,12 +3440,6 @@ newWantedNC loc pty
   | otherwise
   = newWantedEvVarNC loc pty
 
-emitNewDerived :: CtLoc -> TcPredType -> TcS ()
-emitNewDerived loc pred
-  = do { ev <- newDerivedNC loc pred
-       ; traceTcS "Emitting new derived" (ppr ev)
-       ; updWorkListTcS (extendWorkListDerived loc ev) }
-
 emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()
 emitNewDeriveds loc preds
   | null preds
@@ -3127,7 +3447,7 @@ emitNewDeriveds loc preds
   | otherwise
   = do { evs <- mapM (newDerivedNC loc) preds
        ; traceTcS "Emitting new deriveds" (ppr evs)
-       ; updWorkListTcS (extendWorkListDeriveds loc evs) }
+       ; updWorkListTcS (extendWorkListDeriveds evs) }
 
 emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()
 -- Create new equality Derived and put it in the work list
@@ -3135,7 +3455,9 @@ emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()
 emitNewDerivedEq loc role ty1 ty2
   = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)
        ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)
-       ; updWorkListTcS (extendWorkListDerived loc ev) }
+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }
+         -- Very important: put in the wl_eqs
+         -- See Note [Prioritise equalities] (Avoiding fundep iteration)
 
 newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence
 newDerivedNC loc pred
@@ -3183,4 +3505,3 @@ from which we get the implication
    (forall a. t1 ~ t2)
 See TcSMonad.deferTcSForAllEq
 -}
-
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index c898fd96bd..a371f55aad 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -25,6 +25,8 @@ module TcSigs(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import TcHsType
 import TcRnTypes
@@ -32,14 +34,16 @@ import TcRnMonad
 import TcType
 import TcMType
 import TcValidity ( checkValidType )
-import TcUnify( tcSkolemise, unifyType, noThing )
+import TcUnify( tcSkolemise, unifyType )
 import Inst( topInstantiate )
 import TcEnv( tcLookupId )
 import TcEvidence( HsWrapper, (<.>) )
 import Type( mkTyVarBinders )
 
 import DynFlags
-import Var      ( TyVar, tyVarName, tyVarKind )
+import Var      ( TyVar, tyVarKind )
+import VarSet
+import VarEnv   ( mkInScopeSet )
 import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
 import PrelNames( mkUnboundName )
 import BasicTypes
@@ -47,7 +51,6 @@ import Bag( foldrBag )
 import Module( getModule )
 import Name
 import NameEnv
-import VarSet
 import Outputable
 import SrcLoc
 import Util( singleton )
@@ -68,7 +71,7 @@ especially on value bindings.  Here's an overview.
     f = ...g...
     g = ...f...
 
-* HsSyn: a signature in a binding starts of as a TypeSig, in
+* HsSyn: a signature in a binding starts off as a TypeSig, in
   type HsBinds.Sig
 
 * When starting a mutually recursive group, like f/g above, we
@@ -178,20 +181,20 @@ tcTySigs hs_sigs
        ; return (poly_ids, lookupNameEnv env) }
 
 tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
-tcTySig (L _ (IdSig id))
+tcTySig (L _ (IdSig _ id))
   = do { let ctxt = FunSigCtxt (idName id) False
                     -- False: do not report redundant constraints
                     -- The user has no control over the signature!
              sig = completeSigFromId ctxt id
        ; return [TcIdSig sig] }
 
-tcTySig (L loc (TypeSig names sig_ty))
+tcTySig (L loc (TypeSig _ names sig_ty))
   = setSrcSpan loc $
     do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
                           | L _ name <- names ]
        ; return (map TcIdSig sigs) }
 
-tcTySig (L loc (PatSynSig names sig_ty))
+tcTySig (L loc (PatSynSig _ names sig_ty))
   = setSrcSpan loc $
     do { tpsigs <- sequence [ tcPatSynSig name sig_ty
                             | L _ name <- names ]
@@ -248,7 +251,8 @@ completeSigFromId ctxt id
 
 isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
 -- ^ If there are no wildcards, return a LHsSigType
-isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs
+isCompleteHsSig (HsWC { hswc_ext = wcs }) = null wcs
+isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"
 
 {- Note [Fail eagerly on bad signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -287,89 +291,43 @@ Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
 
 * Note that 'forall univ_tvs' and 'req_theta =>'
         and 'forall ex_tvs'   and 'prov_theta =>'
-  are all optional.  We gather the pieces at the the top of tcPatSynSig
+  are all optional.  We gather the pieces at the top of tcPatSynSig
 
 * Initially the implicitly-bound tyvars (added by the renamer) include both
   universal and existential vars.
 
 * After we kind-check the pieces and convert to Types, we do kind generalisation.
-
-Note [The pattern-synonym signature splitting rule]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a pattern signature, we must split
-     the kind-generalised variables, and
-     the implicitly-bound variables
-into universal and existential.  The rule is this
-(see discussion on Trac #11224):
-
-     The universal tyvars are the ones mentioned in
-          - univ_tvs: the user-specified (forall'd) universals
-          - req_theta
-          - res_ty
-     The existential tyvars are all the rest
-
-For example
-
-   pattern P :: () => b -> T a
-   pattern P x = ...
-
-Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
-how do we split the arg_tys from req_ty?  Consider
-
-   pattern Q :: () => b -> S c -> T a
-   pattern Q x = ...
-
-This is an odd example because Q has only one syntactic argument, and
-so presumably is defined by a view pattern matching a function.  But
-it can happen (Trac #11977, #12108).
-
-We don't know Q's arity from the pattern signature, so we have to wait
-until we see the pattern declaration itself before deciding res_ty is,
-and hence which variables are existential and which are universal.
-
-And that in turn is why TcPatSynInfo has a separate field,
-patsig_implicit_bndrs, to capture the implicitly bound type variables,
-because we don't yet know how to split them up.
-
-It's a slight compromise, because it means we don't really know the
-pattern synonym's real signature until we see its declaration.  So,
-for example, in hs-boot file, we may need to think what to do...
-(eg don't have any implicitly-bound variables).
 -}
 
 tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
+-- See Note [Pattern synonym signatures]
+-- See Note [Recipe for checking a signature] in TcHsType
 tcPatSynSig name sig_ty
-  | HsIB { hsib_vars = implicit_hs_tvs
+  | HsIB { hsib_ext = implicit_hs_tvs
          , hsib_body = hs_ty }  <- sig_ty
   , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTy hs_ty
   , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1
-  = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, body_ty))
-           <- solveEqualities $
-              tcImplicitTKBndrs implicit_hs_tvs $
-              tcExplicitTKBndrs univ_hs_tvs  $ \ univ_tvs ->
-              tcExplicitTKBndrs ex_hs_tvs    $ \ ex_tvs   ->
+  = do { (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))
+           <-  -- NB: tcImplicitTKBndrs calls solveLocalEqualities
+              tcImplicitTKBndrs skol_info implicit_hs_tvs $
+              tcExplicitTKBndrs skol_info univ_hs_tvs     $
+              tcExplicitTKBndrs skol_info ex_hs_tvs       $
               do { req     <- tcHsContext hs_req
                  ; prov    <- tcHsContext hs_prov
                  ; body_ty <- tcHsOpenType hs_body_ty
                      -- A (literal) pattern can be unlifted;
                      -- e.g. pattern Zero <- 0#   (Trac #12094)
-                 ; let bound_tvs
-                         = unionVarSets [ allBoundVariabless req
-                                        , allBoundVariabless prov
-                                        , allBoundVariables body_ty
-                                        ]
-                 ; return ( (univ_tvs, req, ex_tvs, prov, body_ty)
-                          , bound_tvs) }
+                 ; return (req, prov, body_ty) }
+
+       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs req
+                                                 ex_tvs prov body_ty
 
        -- Kind generalisation
-       ; kvs <- kindGeneralize $
-                build_patsyn_type [] implicit_tvs univ_tvs req
-                                  ex_tvs prov body_ty
+       ; kvs <- kindGeneralize ungen_patsyn_ty
 
        -- These are /signatures/ so we zonk to squeeze out any kind
-       -- unification variables.  Do this after quantifyTyVars which may
+       -- unification variables.  Do this after kindGeneralize which may
        -- default kind variables to *.
-       ; traceTc "about zonk" empty
        ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
        ; univ_tvs     <- mapM zonkTcTyCoVarBndr univ_tvs
        ; ex_tvs       <- mapM zonkTcTyCoVarBndr ex_tvs
@@ -377,33 +335,46 @@ tcPatSynSig name sig_ty
        ; prov         <- zonkTcTypes prov
        ; body_ty      <- zonkTcType  body_ty
 
+       -- Skolems have TcLevels too, though they're used only for debugging.
+       -- If you don't do this, the debugging checks fail in TcPatSyn.
+       -- Test case: patsyn/should_compile/T13441
+       ; tclvl <- getTcLevel
+       ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs
+             (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs
+             (env2, univ_tvs')     = promoteSkolemsX tclvl env1 univ_tvs
+             (env3, ex_tvs')       = promoteSkolemsX tclvl env2 ex_tvs
+             req'                  = substTys env3 req
+             prov'                 = substTys env3 prov
+             body_ty'              = substTy  env3 body_ty
+
        -- Now do validity checking
        ; checkValidType ctxt $
-         build_patsyn_type kvs implicit_tvs univ_tvs req ex_tvs prov body_ty
+         build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty'
 
        -- arguments become the types of binders. We thus cannot allow
        -- levity polymorphism here
-       ; let (arg_tys, _) = tcSplitFunTys body_ty
+       ; let (arg_tys, _) = tcSplitFunTys body_ty'
        ; mapM_ (checkForLevPoly empty) arg_tys
 
        ; traceTc "tcTySig }" $
-         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'
               , text "kvs" <+> ppr_tvs kvs
-              , text "univ_tvs" <+> ppr_tvs univ_tvs
-              , text "req" <+> ppr req
-              , text "ex_tvs" <+> ppr_tvs ex_tvs
-              , text "prov" <+> ppr prov
-              , text "body_ty" <+> ppr body_ty ]
+              , text "univ_tvs" <+> ppr_tvs univ_tvs'
+              , text "req" <+> ppr req'
+              , text "ex_tvs" <+> ppr_tvs ex_tvs'
+              , text "prov" <+> ppr prov'
+              , text "body_ty" <+> ppr body_ty' ]
        ; return (TPSI { patsig_name = name
-                      , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++
-                                                mkTyVarBinders Specified implicit_tvs
-                      , patsig_univ_bndrs     = univ_tvs
-                      , patsig_req            = req
-                      , patsig_ex_bndrs       = ex_tvs
-                      , patsig_prov           = prov
-                      , patsig_body_ty        = body_ty }) }
+                      , patsig_implicit_bndrs = mkTyVarBinders Inferred  kvs ++
+                                                mkTyVarBinders Specified implicit_tvs'
+                      , patsig_univ_bndrs     = univ_tvs'
+                      , patsig_req            = req'
+                      , patsig_ex_bndrs       = ex_tvs'
+                      , patsig_prov           = prov'
+                      , patsig_body_ty        = body_ty' }) }
   where
     ctxt = PatSynCtxt name
+    skol_info = SigTypeSkol ctxt
 
     build_patsyn_type kvs imp univ req ex prov body
       = mkInvForAllTys kvs $
@@ -412,6 +383,7 @@ tcPatSynSig name sig_ty
         mkSpecForAllTys ex $
         mkFunTys prov $
         body
+tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"
 
 ppr_tvs :: [TyVar] -> SDoc
 ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
@@ -429,7 +401,7 @@ tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
 -- Instantiate a type signature; only used with plan InferGen
 tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
   = setSrcSpan loc $  -- Set the binding site of the tyvars
-    do { (tv_prs, theta, tau) <- tcInstType newMetaSigTyVars poly_id
+    do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id
               -- See Note [Pattern bindings and complete signatures]
 
        ; return (TISI { sig_inst_sig   = sig
@@ -443,13 +415,40 @@ tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty
                           , sig_ctxt = ctxt
                           , sig_loc = loc })
   = setSrcSpan loc $  -- Set the binding site of the tyvars
-    do { (wcs, wcx, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
+    do { (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
+
+        -- Clone the quantified tyvars
+        -- Reason: we might have    f, g :: forall a. a -> _ -> a
+        --         and we want it to behave exactly as if there were
+        --         two separate signatures.  Cloning here seems like
+        --         the easiest way to do so, and is very similar to
+        --         the tcInstType in the CompleteSig case
+        -- See Trac #14643
+       ; let in_scope = mkInScopeSet $ closeOverKinds $ unionVarSets
+                          [ mkVarSet (map snd wcs)
+                          , maybe emptyVarSet tyCoVarsOfType wcx
+                          , mkVarSet tvs
+                          , tyCoVarsOfTypes theta
+                          , tyCoVarsOfType tau ]
+               -- the in_scope is a bit bigger than nec'y, but too big is always
+               -- safe
+             empty_subst = mkEmptyTCvSubst in_scope
+       ; (subst, tvs') <- instSkolTyCoVarsX mk_sig_tv empty_subst tvs
+       ; let tv_prs = tv_names `zip` tvs'
+
        ; return (TISI { sig_inst_sig   = sig
-                      , sig_inst_skols = map (\tv -> (tyVarName tv, tv)) tvs
+                      , sig_inst_skols = tv_prs
                       , sig_inst_wcs   = wcs
                       , sig_inst_wcx   = wcx
-                      , sig_inst_theta = theta
-                      , sig_inst_tau   = tau }) }
+                      , sig_inst_theta = substTys subst theta
+                      , sig_inst_tau   = substTy  subst tau
+                }) }
+  where
+    mk_sig_tv old_name kind
+      = do { uniq <- newUnique
+           ; newTyVarTyVar (setNameUnique old_name uniq) kind }
+      -- Why newTyVarTyVar?  See TcBinds
+      -- Note [Quantified variables in partial type signatures]
 
 
 {- Note [Pattern bindings and complete signatures]
@@ -462,8 +461,8 @@ Consider
 Here we'll infer a type from the pattern of 'T a', but if we feed in
 the signature types for f and g, we'll end up unifying 'a' and 'b'
 
-So we instantiate f and g's signature with SigTv skolems
-(newMetaSigTyVars) that can unify with each other.  If too much
+So we instantiate f and g's signature with TyVarTv skolems
+(newMetaTyVarTyVars) that can unify with each other.  If too much
 unification takes place, we'll find out when we do the final
 impedance-matching check in TcBinds.mkExport
 
@@ -493,15 +492,18 @@ extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
 ---------------
 mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
 mkPragEnv sigs binds
-  = foldl extendPragEnv emptyNameEnv prs
+  = foldl' extendPragEnv emptyNameEnv prs
   where
     prs = mapMaybe get_sig sigs
 
     get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
-    get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig   lnm ty (add_arity nm inl))
-    get_sig (L l (InlineSig lnm@(L _ nm) inl))  = Just (nm, L l $ InlineSig lnm    (add_arity nm inl))
-    get_sig (L l (SCCFunSig st lnm@(L _ nm) str))  = Just (nm, L l $ SCCFunSig st lnm str)
-    get_sig _                                   = Nothing
+    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))
+      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))
+    get_sig (L l (InlineSig x lnm@(L _ nm) inl))
+      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))
+    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
+      = Just (nm, L l $ SCCFunSig x st lnm str)
+    get_sig _ = Nothing
 
     add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
       | Inline <- inl_inline inl_prag
@@ -534,13 +536,13 @@ addInlinePrags poly_id prags_for_me
   | otherwise
   = return poly_id
   where
-    inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me]
+    inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]
 
     warn_multiple_inlines _ [] = return ()
 
     warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
        | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
-       , isEmptyInlineSpec (inlinePragmaSpec prag1)
+       , noUserInlineSpec (inlinePragmaSpec prag1)
        =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
             -- and inl2 is a user NOINLINE pragma; we don't want to complain
          warn_multiple_inlines inl2 inls
@@ -686,7 +688,7 @@ tcSpecPrags poly_id prag_sigs
 
 --------------
 tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
-tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
+tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
 -- See Note [Handling SPECIALISE pragmas]
 --
 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
@@ -722,7 +724,7 @@ tcSpecWrapper ctxt poly_ty spec_ty
   = do { (sk_wrap, inst_wrap)
                <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->
                   do { (inst_wrap, tau) <- topInstantiate orig poly_ty
-                     ; _ <- unifyType noThing spec_tau tau
+                     ; _ <- unifyType Nothing spec_tau tau
                             -- Deliberately ignore the evidence
                             -- See Note [Handling SPECIALISE pragmas],
                             --   wrinkle (2)
@@ -742,8 +744,8 @@ tcImpPrags prags
          else do
             { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
                      [L loc (name,prag)
-                               | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
-                               , not (nameIsLocalOrFrom this_mod name) ]
+                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
+                             , not (nameIsLocalOrFrom this_mod name) ]
             ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
   where
     -- Ignore SPECIALISE pragmas for imported things
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 42c113610b..2a89ab2d41 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -5,11 +5,19 @@ module TcSimplify(
        growThetaTyVars,
        simplifyAmbiguityCheck,
        simplifyDefault,
-       simplifyTop, simplifyTopImplic, captureTopConstraints,
-       simplifyInteractive, solveEqualities,
+       simplifyTop, simplifyTopImplic,
+       simplifyInteractive,
+       solveEqualities, solveLocalEqualities,
        simplifyWantedsTcM,
        tcCheckSatisfiability,
 
+       captureTopConstraints,
+
+       simpl_top,
+
+       promoteTyVar,
+       promoteTyVarSet,
+
        -- For Rules we need these
        solveWanteds, solveWantedsAndDrop,
        approximateWC, runTcSDeriveds
@@ -17,14 +25,16 @@ module TcSimplify(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Bag
 import Class         ( Class, classKey, classTyCon )
 import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )
                      , WarnReason ( Reason )
                      , DynFlags( solverIterations ) )
+import Id            ( idType )
 import Inst
 import ListSetOps
-import Maybes
 import Name
 import Outputable
 import PrelInfo
@@ -32,7 +42,7 @@ import PrelNames
 import TcErrors
 import TcEvidence
 import TcInteract
-import TcCanonical   ( makeSuperClasses )
+import TcCanonical   ( makeSuperClasses, solveCallStack )
 import TcMType   as TcM
 import TcRnMonad as TcM
 import TcSMonad  as TcS
@@ -50,7 +60,10 @@ import ErrUtils      ( emptyMessages )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
-import Data.List     ( partition )
+import Data.Foldable      ( toList )
+import Data.List          ( partition )
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Maybes             ( isJust )
 
 {-
 *********************************************************************************
@@ -65,6 +78,8 @@ captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
 -- generates plus the constraints produced by static forms inside.
 -- If it fails with an exception, it reports any insolubles
 -- (out of scope variables) before doing so
+-- NB: bring any environments into scope before calling this, so that
+-- the reportUnsolved has access to the most complete GlobalRdrEnv
 captureTopConstraints thing_inside
   = do { static_wc_var <- TcM.newTcRef emptyWC ;
        ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $
@@ -117,7 +132,6 @@ simplifyTop wanteds
            ; TcM.writeTcRef errs_var emptyMessages
 
            ; warnAllUnsolved $ WC { wc_simple = unsafe_ol
-                                  , wc_insol = emptyCts
                                   , wc_impl = emptyBag }
 
            ; whyUnsafe <- fst <$> TcM.readTcRef errs_var
@@ -128,14 +142,37 @@ simplifyTop wanteds
 
        ; return (evBindMapBinds binds1 `unionBags` binds2) }
 
+-- | Type-check a thing that emits only equality constraints, solving any
+-- constraints we can and re-emitting constraints that we can't. The thing_inside
+-- should generally bump the TcLevel to make sure that this run of the solver
+-- doesn't affect anything lying around.
+solveLocalEqualities :: TcM a -> TcM a
+solveLocalEqualities thing_inside
+  = do { traceTc "solveLocalEqualities {" empty
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveLocalEqualities: running solver {" (ppr wanted)
+       ; reduced_wanted <- runTcSEqualities (solveWanteds wanted)
+       ; traceTc "solveLocalEqualities: running solver }" (ppr reduced_wanted)
+
+       ; emitConstraints reduced_wanted
+
+       ; traceTc "solveLocalEqualities end }" empty
+       ; return result }
+
 -- | Type-check a thing that emits only equality constraints, then
 -- solve those constraints. Fails outright if there is trouble.
+-- Use this if you're not going to get another crack at solving
+-- (because, e.g., you're checking a datatype declaration)
 solveEqualities :: TcM a -> TcM a
 solveEqualities thing_inside
   = checkNoErrs $  -- See Note [Fail fast on kind errors]
     do { (result, wanted) <- captureConstraints thing_inside
        ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted
        ; final_wc <- runTcSEqualities $ simpl_top wanted
+          -- NB: Use simpl_top here so that we potentially default RuntimeRep
+          -- vars to LiftedRep. This is needed to avoid #14991.
        ; traceTc "End solveEqualities }" empty
 
        ; traceTc "reportAllUnsolved {" empty
@@ -143,6 +180,8 @@ solveEqualities thing_inside
        ; traceTc "reportAllUnsolved }" empty
        ; return result }
 
+-- | Simplify top-level constraints, but without reporting any unsolved
+-- constraints nor unsafe overlapping.
 simpl_top :: WantedConstraints -> TcS WantedConstraints
     -- See Note [Top-level Defaulting Plan]
 simpl_top wanteds
@@ -217,8 +256,9 @@ defaultCallStacks wanteds
          ; setImplicationStatus (implic { ic_wanted = wanteds }) }
 
   defaultCallStack ct
-    | Just _ <- isCallStackPred (ctPred ct)
-    = do { solveCallStack (cc_ev ct) EvCsEmpty
+    | ClassPred cls tys <- classifyPredType (ctPred ct)
+    , Just {} <- isCallStackPred cls tys
+    = do { solveCallStack (ctEvidence ct) EvCsEmpty
          ; return Nothing }
 
   defaultCallStack ct
@@ -374,7 +414,7 @@ How is this implemented? It's complicated! So we'll step through it all:
     the list is null.
 
  2) `TcInteract.matchClassInst` -- This module drives the instance resolution
-    / dictionary generation. The return type is `LookupInstResult`, which either
+    / dictionary generation. The return type is `ClsInstResult`, which either
     says no instance matched, or one found, and if it was a safe or unsafe
     overlap.
 
@@ -501,7 +541,7 @@ tcCheckSatisfiability given_ids
       | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable
       = return insols             -- Hurrah -- stop now.
       | otherwise
-      = do { pending_given <- getPendingScDicts
+      = do { pending_given <- getPendingGivenScs
            ; new_given <- makeSuperClasses pending_given
            ; solveSimpleGivens new_given
            ; getInertInsols }
@@ -576,14 +616,16 @@ simplifyInfer :: TcLevel               -- Used when generating the constraints
               -> WantedConstraints
               -> TcM ([TcTyVar],    -- Quantify over these type variables
                       [EvVar],      -- ... and these constraints (fully zonked)
-                      TcEvBinds)    -- ... binding these evidence variables
+                      TcEvBinds,    -- ... binding these evidence variables
+                      Bool)         -- True <=> there was an insoluble type error
+                                    --          in these bindings
 simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
   | isEmptyWC wanteds
   = do { gbl_tvs <- tcGetGlobalTyCoVars
        ; dep_vars <- zonkTcTypesAndSplitDepVars (map snd name_taus)
        ; qtkvs <- quantifyTyVars gbl_tvs dep_vars
        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
-       ; return (qtkvs, [], emptyTcEvBinds) }
+       ; return (qtkvs, [], emptyTcEvBinds, False) }
 
   | otherwise
   = do { traceTc "simplifyInfer {"  $ vcat
@@ -605,18 +647,18 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
        -- bindings, so we can't just revert to the input
        -- constraint.
 
-       ; tc_lcl_env      <- TcM.getLclEnv
+       ; tc_env          <- TcM.getEnv
        ; ev_binds_var    <- TcM.newTcEvBinds
        ; psig_theta_vars <- mapM TcM.newEvVar psig_theta
        ; wanted_transformed_incl_derivs
             <- setTcLevel rhs_tclvl $
                runTcSWithEvBinds ev_binds_var $
-               do { let loc = mkGivenLoc rhs_tclvl UnkSkol tc_lcl_env
+               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $
+                                      env_lcl tc_env
                         psig_givens = mkGivens loc psig_theta_vars
                   ; _ <- solveSimpleGivens psig_givens
                          -- See Note [Add signature contexts as givens]
-                  ; wanteds' <- solveWanteds wanteds
-                  ; TcS.zonkWC wanteds' }
+                  ; solveWanteds wanteds }
 
        -- Find quant_pred_candidates, the predicates that
        -- we'll consider quantifying over
@@ -624,71 +666,134 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
        --      the psig_theta; it's just the extra bit
        -- NB2: We do not do any defaulting when inferring a type, this can lead
        --      to less polymorphic types, see Note [Default while Inferring]
-
-       ; let wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs
-             quant_pred_candidates   -- Fully zonked
-                 | insolubleWC wanted_transformed_incl_derivs
-                 = []   -- See Note [Quantification with errors]
-                        -- NB: must include derived errors in this test,
-                        --     hence "incl_derivs"
-
-                 | otherwise
-                 = ctsPreds (approximateWC False wanted_transformed)
-
-       -- NB: quant_pred_candidates is already fully zonked
+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs
+       ; let definite_error = insolubleWC wanted_transformed_incl_derivs
+                              -- See Note [Quantification with errors]
+                              -- NB: must include derived errors in this test,
+                              --     hence "incl_derivs"
+             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs
+             quant_pred_candidates
+               | definite_error = []
+               | otherwise      = ctsPreds (approximateWC False wanted_transformed)
 
        -- Decide what type variables and constraints to quantify
+       -- NB: quant_pred_candidates is already fully zonked
        -- NB: bound_theta are constraints we want to quantify over,
-       --     /apart from/ the psig_theta, which we always quantify over
-       ; (qtvs, bound_theta) <- decideQuantification infer_mode rhs_tclvl
+       --     including the psig_theta, which we always quantify over
+       -- NB: bound_theta are fully zonked
+       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl
                                                      name_taus partial_sigs
                                                      quant_pred_candidates
-
-        -- Emit an implication constraint for the
-        -- remaining constraints from the RHS.
-        -- We must retain the psig_theta_vars, because we've used them in
-        -- evidence bindings constructed by solveWanteds earlier
-       ; psig_theta_vars  <- mapM zonkId psig_theta_vars
        ; bound_theta_vars <- mapM TcM.newEvVar bound_theta
-       ; let full_theta      = psig_theta      ++ bound_theta
-             full_theta_vars = psig_theta_vars ++ bound_theta_vars
-             skol_info   = InferSkol [ (name, mkSigmaTy [] full_theta ty)
-                                     | (name, ty) <- name_taus ]
-                        -- Don't add the quantified variables here, because
-                        -- they are also bound in ic_skols and we want them
-                        -- to be tidied uniformly
-
-             implic = Implic { ic_tclvl    = rhs_tclvl
-                             , ic_skols    = qtvs
-                             , ic_no_eqs   = False
-                             , ic_given    = full_theta_vars
-                             , ic_wanted   = wanted_transformed
-                             , ic_status   = IC_Unsolved
-                             , ic_binds    = ev_binds_var
-                             , ic_info     = skol_info
-                             , ic_needed   = emptyVarSet
-                             , ic_env      = tc_lcl_env }
-       ; emitImplication implic
+
+       -- We must produce bindings for the psig_theta_vars, because we may have
+       -- used them in evidence bindings constructed by solveWanteds earlier
+       -- Easiest way to do this is to emit them as new Wanteds (Trac #14643)
+       ; ct_loc <- getCtLocM AnnOrigin Nothing
+       ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var
+                                      , ctev_dest = EvVarDest psig_theta_var
+                                      , ctev_nosh = WDeriv
+                                      , ctev_loc  = ct_loc }
+                           | psig_theta_var <- psig_theta_vars ]
+
+       -- Now we can emil the residual constraints
+       ; emitResidualConstraints rhs_tclvl tc_env ev_binds_var
+                                 name_taus co_vars qtvs
+                                 bound_theta_vars
+                                 (wanted_transformed `andWC` mkSimpleWC psig_wanted)
 
          -- All done!
        ; traceTc "} simplifyInfer/produced residual implication for quantification" $
          vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates
               , text "psig_theta =" <+> ppr psig_theta
               , text "bound_theta =" <+> ppr bound_theta
-              , text "full_theta =" <+> ppr full_theta
               , text "qtvs ="       <+> ppr qtvs
-              , text "implic ="     <+> ppr implic ]
+              , text "definite_error =" <+> ppr definite_error ]
 
-       ; return ( qtvs, full_theta_vars, TcEvBinds ev_binds_var ) }
-         -- NB: full_theta_vars must be fully zonked
+       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }
+         -- NB: bound_theta_vars must be fully zonked
 
 
+--------------------
+emitResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar
+                        -> [(Name, TcTauType)]
+                        -> VarSet -> [TcTyVar] -> [EvVar]
+                        -> WantedConstraints -> TcM ()
+-- Emit the remaining constraints from the RHS.
+-- See Note [Emitting the residual implication in simplifyInfer]
+emitResidualConstraints rhs_tclvl tc_env ev_binds_var
+                        name_taus co_vars qtvs full_theta_vars wanteds
+  | isEmptyWC wanteds
+  = return ()
+  | otherwise
+  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)
+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple
+             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars
+
+        ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)
+
+        ; unless (isEmptyCts outer_simple) $
+          do { traceTc "emitResidualConstrants:simple" (ppr outer_simple)
+             ; emitSimples outer_simple }
+
+        ; implic <- newImplication
+        ; let inner_wanted = wanteds { wc_simple = inner_simple }
+              implic'      = mk_implic inner_wanted implic
+        ; unless (isEmptyWC inner_wanted) $
+          do { traceTc "emitResidualConstraints:implic" (ppr implic')
+             ; emitImplication implic' }
+     }
+  where
+    mk_implic inner_wanted implic
+       = implic { ic_tclvl  = rhs_tclvl
+                , ic_skols  = qtvs
+                , ic_given  = full_theta_vars
+                , ic_wanted = inner_wanted
+                , ic_binds  = ev_binds_var
+                , ic_info   = skol_info
+                , ic_env    = tc_env }
+
+    full_theta = map idType full_theta_vars
+    skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)
+                           | (name, ty) <- name_taus ]
+                 -- Don't add the quantified variables here, because
+                 -- they are also bound in ic_skols and we want them
+                 -- to be tidied uniformly
+
+--------------------
 ctsPreds :: Cts -> [PredType]
 ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts
                              , let ev = ctEvidence ct ]
 
-{- Note [Add signature contexts as givens]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Emitting the residual implication in simplifyInfer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f = e
+where f's type is inferred to be something like (a, Proxy k (Int |> co))
+and we have an as-yet-unsolved, or perhaps insoluble, constraint
+   [W] co :: Type ~ k
+We can't form types like (forall co. blah), so we can't generalise over
+the coercion variable, and hence we can't generalise over things free in
+its kind, in the case 'k'.  But we can still generalise over 'a'.  So
+we'll generalise to
+   f :: forall a. (a, Proxy k (Int |> co))
+Now we do NOT want to form the residual implication constraint
+   forall a. [W] co :: Type ~ k
+because then co's eventual binding (which will be a value binding if we
+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose
+type mentions 'co').  Instead, just as we don't generalise over 'co', we
+should not bury its constraint inside the implication.  Instead, we must
+put it outside.
+
+That is the reason for the partitionBag in emitResidualConstraints,
+which takes the CoVars free in the inferred type, and pulls their
+constraints out.  (NB: this set of CoVars should be
+closed-over-kinds.)
+
+All rather subtle; see Trac #14584.
+
+Note [Add signature contexts as givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this (Trac #11016):
   f2 :: (?x :: Int) => _
   f2 = ?x
@@ -771,12 +876,13 @@ decideQuantification
   -> [TcIdSigInst]         -- Partial type signatures (if any)
   -> [PredType]            -- Candidate theta; already zonked
   -> TcM ( [TcTyVar]       -- Quantify over these (skolems)
-         , [PredType] )    -- and this context (fully zonked)
+         , [PredType]      -- and this context (fully zonked)
+         , VarSet)
 -- See Note [Deciding quantification]
 decideQuantification infer_mode rhs_tclvl name_taus psigs candidates
   = do { -- Step 1: find the mono_tvs
-       ; (mono_tvs, candidates) <- decideMonoTyVars infer_mode
-                                        name_taus psigs candidates
+       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode
+                                              name_taus psigs candidates
 
        -- Step 2: default any non-mono tyvars, and re-simplify
        -- This step may do some unification, but result candidates is zonked
@@ -790,65 +896,104 @@ decideQuantification infer_mode rhs_tclvl name_taus psigs candidates
        -- NB: decideQuantifiedTyVars turned some meta tyvars
        -- into quantified skolems, so we have to zonk again
        ; candidates <- TcM.zonkTcTypes candidates
-       ; let theta = pickQuantifiablePreds (mkVarSet qtvs) $
-                     mkMinimalBySCs $  -- See Note [Minimize by Superclasses]
-                     candidates
+       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)
+       ; let quantifiable_candidates
+               = pickQuantifiablePreds (mkVarSet qtvs) candidates
+             -- NB: do /not/ run pickQuantifiablePreds over psig_theta,
+             -- because we always want to quantify over psig_theta, and not
+             -- drop any of them; e.g. CallStack constraints.  c.f Trac #14658
+
+             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]
+                     (psig_theta ++ quantifiable_candidates)
 
        ; traceTc "decideQuantification"
-           (vcat [ text "infer_mode:"   <+> ppr infer_mode
-                 , text "candidates:"   <+> ppr candidates
-                 , text "mono_tvs:"     <+> ppr mono_tvs
-                 , text "qtvs:"         <+> ppr qtvs
-                 , text "theta:"        <+> ppr theta ])
-       ; return (qtvs, theta) }
+           (vcat [ text "infer_mode:" <+> ppr infer_mode
+                 , text "candidates:" <+> ppr candidates
+                 , text "psig_theta:" <+> ppr psig_theta
+                 , text "mono_tvs:"   <+> ppr mono_tvs
+                 , text "co_vars:"    <+> ppr co_vars
+                 , text "qtvs:"       <+> ppr qtvs
+                 , text "theta:"      <+> ppr theta ])
+       ; return (qtvs, theta, co_vars) }
 
 ------------------
 decideMonoTyVars :: InferMode
                  -> [(Name,TcType)]
                  -> [TcIdSigInst]
                  -> [PredType]
-                 -> TcM (TcTyCoVarSet, [PredType])
--- Decide which tyvars cannot be generalised:
+                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)
+-- Decide which tyvars and covars cannot be generalised:
 --   (a) Free in the environment
 --   (b) Mentioned in a constraint we can't generalise
 --   (c) Connected by an equality to (a) or (b)
--- Also return the reduced set of constraint we can generalise
+-- Also return CoVars that appear free in the final quatified types
+--   we can't quantify over these, and we must make sure they are in scope
 decideMonoTyVars infer_mode name_taus psigs candidates
-  = do { (no_quant, yes_quant) <- pick infer_mode candidates
+  = do { (no_quant, maybe_quant) <- pick infer_mode candidates
 
-       ; gbl_tvs <- tcGetGlobalTyCoVars
-       ; let eq_constraints  = filter isEqPred candidates
-             mono_tvs1       = growThetaTyVars eq_constraints gbl_tvs
-             constrained_tvs = growThetaTyVars eq_constraints
-                                               (tyCoVarsOfTypes no_quant)
-                               `minusVarSet` mono_tvs1
-             mono_tvs2       = mono_tvs1 `unionVarSet` constrained_tvs
-             -- A type variable is only "constrained" (so that the MR bites)
-             -- if it is not free in the environment (Trac #13785)
-
-       -- Always quantify over partial-sig qtvs, so they are not mono
-       -- Need to zonk them because they are meta-tyvar SigTvs
-       -- Note [Quantification and partial signatures], wrinkle 3
+       -- If possible, we quantify over partial-sig qtvs, so they are
+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs
        ; psig_qtvs <- mapM zonkTcTyVarToTyVar $
                       concatMap (map snd . sig_inst_skols) psigs
-       ; let mono_tvs = mono_tvs2 `delVarSetList` psig_qtvs
+
+       ; psig_theta <- mapM TcM.zonkTcType $
+                       concatMap sig_inst_theta psigs
+
+       ; taus <- mapM (TcM.zonkTcType . snd) name_taus
+
+       ; mono_tvs0 <- tcGetGlobalTyCoVars
+       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta
+
+             co_vars = coVarsOfTypes (psig_tys ++ taus)
+             co_var_tvs = closeOverKinds co_vars
+               -- The co_var_tvs are tvs mentioned in the types of covars or
+               -- coercion holes. We can't quantify over these covars, so we
+               -- must include the variable in their types in the mono_tvs.
+               -- E.g.  If we can't quantify over co :: k~Type, then we can't
+               --       quantify over k either!  Hence closeOverKinds
+
+             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs
+
+             eq_constraints = filter isEqPred candidates
+             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1
+
+             constrained_tvs = (growThetaTyVars eq_constraints
+                                               (tyCoVarsOfTypes no_quant)
+                                `minusVarSet` mono_tvs2)
+                               `delVarSetList` psig_qtvs
+             -- constrained_tvs: the tyvars that we are not going to
+             -- quantify solely because of the moonomorphism restriction
+             --
+             -- (`minusVarSet` mono_tvs1`): a type variable is only
+             --   "constrained" (so that the MR bites) if it is not
+             --   free in the environment (Trac #13785)
+             --
+             -- (`delVarSetList` psig_qtvs): if the user has explicitly
+             --   asked for quantification, then that request "wins"
+             --   over the MR.  Note: do /not/ delete psig_qtvs from
+             --   mono_tvs1, because mono_tvs1 cannot under any circumstances
+             --   be quantified (Trac #14479); see
+             --   Note [Quantification and partial signatures], Wrinkle 3, 4
+
+             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs
 
            -- Warn about the monomorphism restriction
        ; warn_mono <- woptM Opt_WarnMonomorphism
        ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $
-         do { taus <- mapM (TcM.zonkTcType . snd) name_taus
-            ; warnTc (Reason Opt_WarnMonomorphism)
-                     (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)
-                     mr_msg }
+         warnTc (Reason Opt_WarnMonomorphism)
+                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)
+                mr_msg
 
        ; traceTc "decideMonoTyVars" $ vcat
-           [ text "gbl_tvs =" <+> ppr gbl_tvs
+           [ text "mono_tvs0 =" <+> ppr mono_tvs0
+           , text "mono_tvs1 =" <+> ppr mono_tvs1
            , text "no_quant =" <+> ppr no_quant
-           , text "yes_quant =" <+> ppr yes_quant
+           , text "maybe_quant =" <+> ppr maybe_quant
            , text "eq_constraints =" <+> ppr eq_constraints
-           , text "mono_tvs =" <+> ppr mono_tvs ]
+           , text "mono_tvs =" <+> ppr mono_tvs
+           , text "co_vars =" <+> ppr co_vars ]
 
-       ; return (mono_tvs, yes_quant) }
+       ; return (mono_tvs, maybe_quant, co_vars) }
   where
     pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
     -- Split the candidates into ones we definitely
@@ -885,12 +1030,8 @@ defaultTyVarsAndSimplify :: TcLevel
 defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
   = do {  -- Promote any tyvars that we cannot generalise
           -- See Note [Promote momomorphic tyvars]
-       ; outer_tclvl <- TcM.getTcLevel
-       ; let prom_tvs = nonDetEltsUniqSet mono_tvs
-                        -- It's OK to use nonDetEltsUniqSet here
-                        -- because promoteTyVar is commutative
-       ; traceTc "decideMonoTyVars: promotion:" (ppr prom_tvs)
-       ; proms <- mapM (promoteTyVar outer_tclvl) prom_tvs
+       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)
+       ; (prom, _) <- promoteTyVarSet mono_tvs
 
        -- Default any kind/levity vars
        ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
@@ -904,7 +1045,7 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
 
        ; case () of
            _ | some_default -> simplify_cand candidates
-             | or proms     -> mapM TcM.zonkTcType candidates
+             | prom         -> mapM TcM.zonkTcType candidates
              | otherwise    -> return candidates
        }
   where
@@ -939,19 +1080,20 @@ decideQuantifiedTyVars
 decideQuantifiedTyVars mono_tvs name_taus psigs candidates
   = do {     -- Why psig_tys? We try to quantify over everything free in here
              -- See Note [Quantification and partial signatures]
-             --     wrinkles 2 and 3
+             --     Wrinkles 2 and 3
        ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs
                                                   , (_,tv) <- sig_inst_skols sig ]
        ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs
                                                   , pred <- sig_inst_theta sig ]
-       ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus
+       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus
+       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs
 
        ; let -- Try to quantify over variables free in these types
              psig_tys = psig_tv_tys ++ psig_theta
              seed_tys = psig_tys ++ tau_tys
 
              -- Now "grow" those seeds to find ones reachable via 'candidates'
-             grown_tvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)
+             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)
 
        -- Now we have to classify them into kind variables and type variables
        -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars
@@ -962,33 +1104,35 @@ decideQuantifiedTyVars mono_tvs name_taus psigs candidates
        ; let DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
                       = candidateQTyVarsOfTypes $
                         psig_tys ++ candidates ++ tau_tys
-             pick     = (`dVarSetIntersectVarSet` grown_tvs)
+             pick     = (`dVarSetIntersectVarSet` grown_tcvs)
              dvs_plus = DV { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
 
-       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs
+       ; traceTc "decideQuantifiedTyVars" (vcat
+           [ text "seed_tys =" <+> ppr seed_tys
+           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)
+           , text "grown_tcvs =" <+> ppr grown_tcvs])
+
        ; quantifyTyVars mono_tvs dvs_plus }
 
 ------------------
-growThetaTyVars :: ThetaType -> TyCoVarSet -> TyVarSet
+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
 -- See Note [Growing the tau-tvs using constraints]
--- NB: only returns tyvars, never covars
-growThetaTyVars theta tvs
-  | null theta = tvs_only
-  | otherwise  = filterVarSet isTyVar $
-                 transCloVarSet mk_next seed_tvs
+growThetaTyVars theta tcvs
+  | null theta = tcvs
+  | otherwise  = transCloVarSet mk_next seed_tcvs
   where
-    tvs_only = filterVarSet isTyVar tvs
-    seed_tvs = tvs `unionVarSet` tyCoVarsOfTypes ips
+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
     (ips, non_ips) = partition isIPPred theta
                          -- See Note [Inheriting implicit parameters] in TcType
 
     mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
     mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips
-    grow_one so_far pred tvs
-       | pred_tvs `intersectsVarSet` so_far = tvs `unionVarSet` pred_tvs
-       | otherwise                          = tvs
+    grow_one so_far pred tcvs
+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs
+       | otherwise                           = tcvs
        where
-         pred_tvs = tyCoVarsOfType pred
+         pred_tcvs = tyCoVarsOfType pred
+
 
 {- Note [Promote momomorphic tyvars]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1021,7 +1165,7 @@ However, in the case of a partial type signature, be doing inference
 or
    g :: (Eq _a) => _b -> _b
 In both cases we use plan InferGen, and hence call simplifyInfer.  But
-those 'a' variables are skolems (actually SigTvs), and we should be
+those 'a' variables are skolems (actually TyVarTvs), and we should be
 sure to quantify over them.  This leads to several wrinkles:
 
 * Wrinkle 1.  In the case of a type error
@@ -1052,30 +1196,22 @@ sure to quantify over them.  This leads to several wrinkles:
 
 * Wrinkle 3 (Trac #13482). Also consider
     f :: forall a. _ => Int -> Int
-    f x = if undefined :: a == undefined then x else 0
+    f x = if (undefined :: a) == undefined then x else 0
   Here we get an (Eq a) constraint, but it's not mentioned in the
-  psig_theta nor the type of 'f'.  Moreover, if we have
-    f :: forall a. a -> _
-    f x = not x
-  and a constraint (a ~ g), where 'g' is free in the environment,
-  we would not usually quanitfy over 'a'.  But here we should anyway
-  (leading to a justified subsequent error) since 'a' is explicitly
-  quantified by the programmer.
-
-  Bottom line: always quantify over the psig_tvs, regardless.
+  psig_theta nor the type of 'f'.  But we still want to quantify
+  over 'a' even if the monomorphism restriction is on.
 
-Note [Quantifying over equality constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Should we quantify over an equality constraint (s ~ t)?  In general, we don't.
-Doing so may simply postpone a type error from the function definition site to
-its call site.  (At worst, imagine (Int ~ Bool)).
+* Wrinkle 4 (Trac #14479)
+    foo :: Num a => a -> a
+    foo xxx = g xxx
+      where
+        g :: forall b. Num b => _ -> b
+        g y = xxx + y
 
-However, consider this
-         forall a. (F [a] ~ Int) => blah
-Should we quantify over the (F [a] ~ Int)?  Perhaps yes, because at the call
-site we will know 'a', and perhaps we have instance  F [Bool] = Int.
-So we *do* quantify over a type-family equality where the arguments mention
-the quantified variables.
+  In the signature for 'g', we cannot quantify over 'b' because it turns out to
+  get unified with 'a', which is free in g's environment.  So we carefully
+  refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars.  We
+  report the error later, in TcBinds.chooseInferredQuantifiers.
 
 Note [Growing the tau-tvs using constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1092,13 +1228,33 @@ Notice that
 Note [Quantification with errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we find that the RHS of the definition has some absolutely-insoluble
-constraints, we abandon all attempts to find a context to quantify
-over, and instead make the function fully-polymorphic in whatever
-type we have found.  For two reasons
-  a) Minimise downstream errors
-  b) Avoid spurious errors from this function
-
-But NB that we must include *derived* errors in the check. Example:
+constraints (including especially "variable not in scope"), we
+
+* Abandon all attempts to find a context to quantify over,
+  and instead make the function fully-polymorphic in whatever
+  type we have found
+
+* Return a flag from simplifyInfer, indicating that we found an
+  insoluble constraint.  This flag is used to suppress the ambiguity
+  check for the inferred type, which may well be bogus, and which
+  tends to obscure the real error.  This fix feels a bit clunky,
+  but I failed to come up with anything better.
+
+Reasons:
+    - Avoid downstream errors
+    - Do not perform an ambiguity test on a bogus type, which might well
+      fail spuriously, thereby obfuscating the original insoluble error.
+      Trac #14000 is an example
+
+I tried an alternative approach: simply failM, after emitting the
+residual implication constraint; the exception will be caught in
+TcBinds.tcPolyBinds, which gives all the binders in the group the type
+(forall a. a).  But that didn't work with -fdefer-type-errors, because
+the recovery from failM emits no code at all, so there is no function
+to run!   But -fdefer-type-errors aspires to produce a runnable program.
+
+NB that we must include *derived* errors in the check for insolubles.
+Example:
     (a::*) ~ Int#
 We get an insoluble derived error *~#, and we don't want to discard
 it before doing the isInsolubleWC test!  (Trac #8262)
@@ -1204,42 +1360,34 @@ solveWantedsAndDrop wanted
 solveWanteds :: WantedConstraints -> TcS WantedConstraints
 -- so that the inert set doesn't mindlessly propagate.
 -- NB: wc_simples may be wanted /or/ derived now
-solveWanteds wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
-  = do { traceTcS "solveWanteds {" (ppr wc)
-
-       ; wc1 <- solveSimpleWanteds (simples `unionBags` insols)
-                -- Why solve 'insols'?  See Note [Rewrite insolubles] in TcSMonad
-
-       ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1
+solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { cur_lvl <- TcS.getTcLevel
+       ; traceTcS "solveWanteds {" $
+         vcat [ text "Level =" <+> ppr cur_lvl
+              , ppr wc ]
 
-       ; (floated_eqs, implics2) <- solveNestedImplications (implics `unionBags` implics1)
-       ; (no_new_scs, simples2)  <- expandSuperClasses simples1
+       ; wc1 <- solveSimpleWanteds simples
+                -- Any insoluble constraints are in 'simples' and so get rewritten
+                -- See Note [Rewrite insolubles] in TcSMonad
 
-       ; traceTcS "solveWanteds middle" $ vcat [ text "simples1 =" <+> ppr simples1
-                                               , text "simples2 =" <+> ppr simples2 ]
+       ; (floated_eqs, implics2) <- solveNestedImplications $
+                                    implics `unionBags` wc_impl wc1
 
-       ; dflags <- getDynFlags
+       ; dflags   <- getDynFlags
        ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs
-                                no_new_scs
-                                (WC { wc_simple = simples2
-                                    , wc_insol  = insols1
-                                    , wc_impl   = implics2 })
+                                (wc1 { wc_impl = implics2 })
 
-       ; bb <- TcS.getTcEvBindsMap
+       ; ev_binds_var <- getTcEvBindsVar
+       ; bb <- TcS.getTcEvBindsMap ev_binds_var
        ; traceTcS "solveWanteds }" $
                  vcat [ text "final wc =" <+> ppr final_wc
                       , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]
 
        ; return final_wc }
 
-simpl_loop :: Int -> IntWithInf -> Cts -> Bool
-           -> WantedConstraints
-           -> TcS WantedConstraints
-simpl_loop n limit floated_eqs no_new_deriveds
-           wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
-  | isEmptyBag floated_eqs && no_new_deriveds
-  = return wc  -- Done!
-
+simpl_loop :: Int -> IntWithInf -> Cts
+           -> WantedConstraints -> TcS WantedConstraints
+simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples })
   | n `intGtLimit` limit
   = do { -- Add an error (not a warning) if we blow the limit,
          -- Typically if we blow the limit we are going to report some other error
@@ -1250,74 +1398,67 @@ simpl_loop n limit floated_eqs no_new_deriveds
                 2 (vcat [ text "Unsolved:" <+> ppr wc
                         , ppUnless (isEmptyBag floated_eqs) $
                           text "Floated equalities:" <+> ppr floated_eqs
-                        , ppUnless no_new_deriveds $
-                          text "New deriveds found"
                         , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
                   ]))
        ; return wc }
 
+  | not (isEmptyBag floated_eqs)
+  = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples })
+            -- Put floated_eqs first so they get solved first
+            -- NB: the floated_eqs may include /derived/ equalities
+            -- arising from fundeps inside an implication
+
+  | superClassesMightHelp wc
+  = -- We still have unsolved goals, and apparently no way to solve them,
+    -- so try expanding superclasses at this level, both Given and Wanted
+    do { pending_given <- getPendingGivenScs
+       ; let (pending_wanted, simples1) = getPendingWantedScs simples
+       ; if null pending_given && null pending_wanted
+           then return wc  -- After all, superclasses did not help
+           else
+    do { new_given  <- makeSuperClasses pending_given
+       ; new_wanted <- makeSuperClasses pending_wanted
+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set
+       ; simplify_again n limit (null pending_given)
+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
+
   | otherwise
-  = do { let n_floated = lengthBag floated_eqs
-       ; csTraceTcS $
+  = return wc
+
+simplify_again :: Int -> IntWithInf -> Bool
+               -> WantedConstraints -> TcS WantedConstraints
+-- We have definitely decided to have another go at solving
+-- the wanted constraints (we have tried at least once already
+simplify_again n limit no_new_given_scs
+               wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { csTraceTcS $
          text "simpl_loop iteration=" <> int n
-         <+> (parens $ hsep [ text "no new deriveds =" <+> ppr no_new_deriveds <> comma
-                            , int n_floated <+> text "floated eqs" <> comma
+         <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma
                             , int (lengthBag simples) <+> text "simples to solve" ])
+       ; traceTcS "simpl_loop: wc =" (ppr wc)
 
-       -- solveSimples may make progress if either float_eqs hold
        ; (unifs1, wc1) <- reportUnifications $
                           solveSimpleWanteds $
-                          floated_eqs `unionBags` simples `unionBags` insols
-            -- Notes:
-            --   - Why solve 'insols'?  See Note [Rewrite insolubles] in TcSMonad
-            --   - Put floated_eqs first so they get solved first
-            --     NB: the floated_eqs may include /derived/ equalities
-            --     arising from fundeps inside an implication
-
-       ; let WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 } = wc1
-       ; (no_new_scs, simples2) <- expandSuperClasses simples1
+                          simples
 
+       -- See Note [Cutting off simpl_loop]
        -- We have already tried to solve the nested implications once
        -- Try again only if we have unified some meta-variables
-       -- (which is a bit like adding more givens)
-       -- See Note [Cutting off simpl_loop]
-       ; (floated_eqs2, implics2) <- if unifs1 == 0 && isEmptyBag implics1
-                                     then return (emptyBag, implics)
-                                     else solveNestedImplications (implics `unionBags` implics1)
-
-       ; simpl_loop (n+1) limit floated_eqs2 no_new_scs
-                    (WC { wc_simple = simples2
-                        , wc_insol  = insols1
-                        , wc_impl   = implics2 }) }
-
-
-expandSuperClasses :: Cts -> TcS (Bool, Cts)
--- If there are any unsolved wanteds, expand one step of
--- superclasses for deriveds
--- Returned Bool is True <=> no new superclass constraints added
--- See Note [The superclass story] in TcCanonical
-expandSuperClasses unsolved
-  | not (anyBag superClassesMightHelp unsolved)
-  = return (True, unsolved)
-  | otherwise
-  = do { traceTcS "expandSuperClasses {" empty
-       ; let (pending_wanted, unsolved') = mapAccumBagL get [] unsolved
-             get acc ct | Just ct' <- isPendingScDict ct
-                        = (ct':acc, ct')
-                        | otherwise
-                        = (acc,     ct)
-       ; pending_given <- getPendingScDicts
-       ; if null pending_given && null pending_wanted
-         then do { traceTcS "End expandSuperClasses no-op }" empty
-                 ; return (True, unsolved) }
-         else
-    do { new_given  <- makeSuperClasses pending_given
-       ; solveSimpleGivens new_given
-       ; new_wanted <- makeSuperClasses pending_wanted
-       ; traceTcS "End expandSuperClasses }"
-                  (vcat [ text "Given:" <+> ppr pending_given
-                        , text "Wanted:" <+> ppr new_wanted ])
-       ; return (False, unsolved' `unionBags` listToBag new_wanted) } }
+       -- (which is a bit like adding more givens), or we have some
+       -- new Given superclasses
+       ; let new_implics = wc_impl wc1
+       ; if unifs1 == 0       &&
+            no_new_given_scs  &&
+            isEmptyBag new_implics
+
+           then -- Do not even try to solve the implications
+                simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics })
+
+           else -- Try to solve the implications
+                do { (floated_eqs2, implics2) <- solveNestedImplications $
+                                                 implics `unionBags` new_implics
+                   ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 })
+    } }
 
 solveNestedImplications :: Bag Implication
                         -> TcS (Cts, Bag Implication)
@@ -1351,8 +1492,7 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
                              , ic_given  = given_ids
                              , ic_wanted = wanteds
                              , ic_info   = info
-                             , ic_status = status
-                             , ic_env    = env })
+                             , ic_status = status })
   | isSolvedStatus status
   = return (emptyCts, Just imp)  -- Do nothing
 
@@ -1363,10 +1503,13 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
   = do { inerts <- getTcSInerts
        ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
 
+       -- commented out; see `where` clause below
+       -- ; when debugIsOn check_tc_level
+
          -- Solve the nested constraints
        ; (no_given_eqs, given_insols, residual_wanted)
             <- nestImplicTcS ev_binds_var tclvl $
-               do { let loc    = mkGivenLoc tclvl info env
+               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)
                         givens = mkGivens loc given_ids
                   ; solveSimpleGivens givens
 
@@ -1383,16 +1526,20 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
                   ; return (no_eqs, given_insols, residual_wanted) }
 
        ; (floated_eqs, residual_wanted)
-             <- floatEqualities skols no_given_eqs residual_wanted
+             <- floatEqualities skols given_ids ev_binds_var
+                                no_given_eqs residual_wanted
 
        ; traceTcS "solveImplication 2"
            (ppr given_insols $$ ppr residual_wanted)
        ; let final_wanted = residual_wanted `addInsols` given_insols
+             -- Don't lose track of the insoluble givens,
+             -- which signal unreachable code; put them in ic_wanted
 
        ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs
                                                  , ic_wanted = final_wanted })
 
-       ; (evbinds, tcvs) <- TcS.getTcEvBindsAndTCVs ev_binds_var
+       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var
+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var
        ; traceTcS "solveImplication end }" $ vcat
              [ text "no_given_eqs =" <+> ppr no_given_eqs
              , text "floated_eqs =" <+> ppr floated_eqs
@@ -1402,6 +1549,18 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
 
        ; return (floated_eqs, res_implic) }
 
+  where
+    -- TcLevels must be strictly increasing (see (ImplicInv) in
+    -- Note [TcLevel and untouchable type variables] in TcType),
+    -- and in fact I thinkthey should always increase one level at a time.
+
+    -- Though sensible, this check causes lots of testsuite failures. It is
+    -- remaining commented out for now.
+    {-
+    check_tc_level = do { cur_lvl <- TcS.getTcLevel
+                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }
+    -}
+
 ----------------------
 setImplicationStatus :: Implication -> TcS (Maybe Implication)
 -- Finalise the implication returned from solveImplication:
@@ -1409,99 +1568,101 @@ setImplicationStatus :: Implication -> TcS (Maybe Implication)
 --    * Trim the ic_wanted field to remove Derived constraints
 -- Precondition: the ic_status field is not already IC_Solved
 -- Return Nothing if we can discard the implication altogether
-setImplicationStatus implic@(Implic { ic_binds  = ev_binds_var
-                                    , ic_status = status
-                                    , ic_info   = info
-                                    , ic_wanted = wc
-                                    , ic_needed = old_discarded_needs
-                                    , ic_given  = givens })
+setImplicationStatus implic@(Implic { ic_status     = status
+                                    , ic_info       = info
+                                    , ic_wanted     = wc
+                                    , ic_given      = givens })
  | ASSERT2( not (isSolvedStatus status ), ppr info )
    -- Precondition: we only set the status if it is not already solved
-   some_insoluble
- = return $ Just $
-   implic { ic_status = IC_Insoluble
-          , ic_needed = new_discarded_needs
-          , ic_wanted = pruned_wc }
-
- | some_unsolved
- = do { traceTcS "setImplicationStatus" $
-        vcat [ppr givens $$ ppr simples $$ ppr insols $$ ppr mb_implic_needs]
-      ; return $ Just $
-        implic { ic_status = IC_Unsolved
-               , ic_needed = new_discarded_needs
-               , ic_wanted = pruned_wc }
-   }
-
- | otherwise  -- Everything is solved; look at the implications
+   not (isSolvedWC pruned_wc)
+ = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
+
+      ; implic <- neededEvVars implic
+
+      ; let new_status | insolubleWC pruned_wc = IC_Insoluble
+                       | otherwise             = IC_Unsolved
+            new_implic = implic { ic_status = new_status
+                                , ic_wanted = pruned_wc }
+
+      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)
+
+      ; return $ Just new_implic }
+
+ | otherwise  -- Everything is solved
+              -- Set status to IC_Solved,
+              -- and compute the dead givens and outer needs
               -- See Note [Tracking redundant constraints]
- = do { ev_binds <- TcS.getTcEvBindsAndTCVs ev_binds_var
-      ; let all_needs = neededEvVars ev_binds $
-                        solved_implic_needs `unionVarSet` new_discarded_needs
+ = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)
 
-            dead_givens | warnRedundantGivens info
-                        = filterOut (`elemVarSet` all_needs) givens
-                        | otherwise = []   -- None to report
+      ; implic@(Implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) <- neededEvVars implic
+
+      ; bad_telescope <- checkBadTelescope implic
 
-            final_needs = all_needs `delVarSetList` givens
+      ; let dead_givens | warnRedundantGivens info
+                        = filterOut (`elemVarSet` need_inner) givens
+                        | otherwise = []   -- None to report
 
             discard_entire_implication  -- Can we discard the entire implication?
               =  null dead_givens           -- No warning from this implication
-              && isEmptyBag pruned_implics  -- No live children
-              && isEmptyVarSet final_needs  -- No needed vars to pass up to parent
+              && not bad_telescope
+              && isEmptyWC pruned_wc        -- No live children
+              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent
 
-            final_status = IC_Solved { ics_need = final_needs
-                                     , ics_dead = dead_givens }
+            final_status
+              | bad_telescope = IC_BadTelescope
+              | otherwise     = IC_Solved { ics_dead = dead_givens }
             final_implic = implic { ic_status = final_status
-                                  , ic_needed = emptyVarSet -- Irrelevant for IC_Solved
                                   , ic_wanted = pruned_wc }
 
-        -- Check that there are no term-level evidence bindings
-        -- in the cases where we have no place to put them
-      ; MASSERT2( termEvidenceAllowed info || isEmptyEvBindMap (fst ev_binds)
-                , ppr info $$ ppr ev_binds )
+      ; traceTcS "setImplicationStatus(all-solved) }" $
+        vcat [ text "discard:" <+> ppr discard_entire_implication
+             , text "new_implic:" <+> ppr final_implic ]
 
-      ; traceTcS "setImplicationStatus 2" $
-        vcat [ppr givens $$ ppr ev_binds $$ ppr all_needs]
       ; return $ if discard_entire_implication
                  then Nothing
                  else Just final_implic }
  where
-   WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc
-
-   some_insoluble = insolubleWC wc
-   some_unsolved = not (isEmptyBag simples && isEmptyBag insols)
-                 || isNothing mb_implic_needs
+   WC { wc_simple = simples, wc_impl = implics } = wc
 
    pruned_simples = dropDerivedSimples simples
-   pruned_insols  = dropDerivedInsols insols
-   (pruned_implics, discarded_needs) = partitionBagWith discard_me implics
-   pruned_wc = wc { wc_simple = pruned_simples
-                  , wc_insol  = pruned_insols
+   pruned_implics = filterBag keep_me implics
+   pruned_wc = WC { wc_simple = pruned_simples
                   , wc_impl   = pruned_implics }
-   new_discarded_needs = foldrBag unionVarSet old_discarded_needs discarded_needs
-
-   mb_implic_needs :: Maybe VarSet
-        -- Just vs => all implics are IC_Solved, with 'vs' needed
-        -- Nothing => at least one implic is not IC_Solved
-   mb_implic_needs   = foldrBag add_implic (Just emptyVarSet) pruned_implics
-   Just solved_implic_needs = mb_implic_needs
-
-   add_implic implic acc
-      | Just vs_acc <- acc
-      , IC_Solved { ics_need = vs } <- ic_status implic
-      = Just (vs `unionVarSet` vs_acc)
-      | otherwise = Nothing
-
-   discard_me :: Implication -> Either Implication VarSet
-   discard_me ic
-     | IC_Solved { ics_dead = dead_givens, ics_need = needed } <- ic_status ic
+
+   keep_me :: Implication -> Bool
+   keep_me ic
+     | IC_Solved { ics_dead = dead_givens } <- ic_status ic
                           -- Fully solved
      , null dead_givens   -- No redundant givens to report
      , isEmptyBag (wc_impl (ic_wanted ic))
            -- And no children that might have things to report
-     = Right needed
+     = False       -- Tnen we don't need to keep it
      | otherwise
-     = Left ic
+     = True        -- Otherwise, keep it
+
+checkBadTelescope :: Implication -> TcS Bool
+-- True <=> the skolems form a bad telescope
+-- See Note [Keeping scoped variables in order: Explicit] in TcHsType
+checkBadTelescope (Implic { ic_telescope  = m_telescope
+                          , ic_skols      = skols })
+  | isJust m_telescope
+  = do{ skols <- mapM TcS.zonkTcTyCoVarBndr skols
+      ; return (go emptyVarSet (reverse skols))}
+
+  | otherwise
+  = return False
+
+  where
+    go :: TyVarSet   -- skolems that appear *later* than the current ones
+       -> [TcTyVar]  -- ordered skolems, in reverse order
+       -> Bool       -- True <=> there is an out-of-order skolem
+    go _ [] = False
+    go later_skols (one_skol : earlier_skols)
+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols
+      = True
+      | otherwise
+      = go (later_skols `extendVarSet` one_skol) earlier_skols
 
 warnRedundantGivens :: SkolemInfo -> Bool
 warnRedundantGivens (SigSkol ctxt _ _)
@@ -1515,41 +1676,113 @@ warnRedundantGivens (SigSkol ctxt _ _)
 warnRedundantGivens (InstSkol {}) = True
 warnRedundantGivens _             = False
 
-neededEvVars :: (EvBindMap, TcTyVarSet) -> VarSet -> VarSet
+neededEvVars :: Implication -> TcS Implication
 -- Find all the evidence variables that are "needed",
---    and then delete all those bound by the evidence bindings
--- See Note [Tracking redundant constraints]
-neededEvVars (ev_binds, tcvs) initial_seeds
- = (needed `unionVarSet` tcvs) `minusVarSet` bndrs
+-- and delete dead evidence bindings
+--   See Note [Tracking redundant constraints]
+--   See Note [Delete dead Given evidence bindings]
+--
+--   - Start from initial_seeds (from nested implications)
+--
+--   - Add free vars of RHS of all Wanted evidence bindings
+--     and coercion variables accumulated in tcvs (all Wanted)
+--
+--   - Generate 'needed', the needed set of EvVars, by doing transitive
+--     closure through Given bindings
+--     e.g.   Needed {a,b}
+--            Given  a = sc_sel a2
+--            Then a2 is needed too
+--
+--   - Prune out all Given bindings that are not needed
+--
+--   - From the 'needed' set, delete ev_bndrs, the binders of the
+--     evidence bindings, to give the final needed variables
+--
+neededEvVars implic@(Implic { ic_given = givens
+                            , ic_binds = ev_binds_var
+                            , ic_wanted = WC { wc_impl = implics }
+                            , ic_need_inner = old_needs })
+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
+      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var
+
+      ; let seeds1        = foldrBag add_implic_seeds old_needs implics
+            seeds2        = foldEvBindMap add_wanted seeds1 ev_binds
+            seeds3        = seeds2 `unionVarSet` tcvs
+            need_inner    = findNeededEvVars ev_binds seeds3
+            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
+            need_outer    = foldEvBindMap del_ev_bndr need_inner live_ev_binds
+                            `delVarSetList` givens
+
+      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
+           -- See Note [Delete dead Given evidence bindings]
+
+      ; traceTcS "neededEvVars" $
+        vcat [ text "old_needs:" <+> ppr old_needs
+             , text "seeds3:" <+> ppr seeds3
+             , text "tcvs:" <+> ppr tcvs
+             , text "ev_binds:" <+> ppr ev_binds
+             , text "live_ev_binds:" <+> ppr live_ev_binds ]
+
+      ; return (implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) }
  where
-   seeds  = foldEvBindMap add_wanted initial_seeds ev_binds
-   needed = transCloVarSet also_needs seeds
-   bndrs  = foldEvBindMap add_bndr emptyVarSet ev_binds
+   add_implic_seeds (Implic { ic_need_outer = needs, ic_given = givens }) acc
+      = (needs `delVarSetList` givens) `unionVarSet` acc
+
+   needed_ev_bind needed (EvBind { eb_lhs = ev_var
+                                 , eb_is_given = is_given })
+     | is_given  = ev_var `elemVarSet` needed
+     | otherwise = True   -- Keep all wanted bindings
+
+   del_ev_bndr :: EvBind -> VarSet -> VarSet
+   del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v
 
    add_wanted :: EvBind -> VarSet -> VarSet
    add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
      | is_given  = needs  -- Add the rhs vars of the Wanted bindings only
      | otherwise = evVarsOfTerm rhs `unionVarSet` needs
 
-   also_needs :: VarSet -> VarSet
-   also_needs needs
-     = nonDetFoldUniqSet add emptyVarSet needs
-     -- It's OK to use nonDetFoldUFM here because we immediately forget
-     -- about the ordering by creating a set
-     where
-       add v needs
-        | Just ev_bind <- lookupEvBind ev_binds v
-        , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind
-        , is_given
-        = evVarsOfTerm rhs `unionVarSet` needs
-        | otherwise
-        = needs
 
-   add_bndr :: EvBind -> VarSet -> VarSet
-   add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v
+{- Note [Delete dead Given evidence bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As a result of superclass expansion, we speculatively
+generate evidence bindings for Givens. E.g.
+   f :: (a ~ b) => a -> b -> Bool
+   f x y = ...
+We'll have
+   [G] d1 :: (a~b)
+and we'll specuatively generate the evidence binding
+   [G] d2 :: (a ~# b) = sc_sel d
 
+Now d2 is available for solving.  But it may not be needed!  Usually
+such dead superclass selections will eventually be dropped as dead
+code, but:
+
+ * It won't always be dropped (Trac #13032).  In the case of an
+   unlifted-equality superclass like d2 above, we generate
+       case heq_sc d1 of d2 -> ...
+   and we can't (in general) drop that case exrpession in case
+   d1 is bottom.  So it's technically unsound to have added it
+   in the first place.
+
+ * Simply generating all those extra superclasses can generate lots of
+   code that has to be zonked, only to be discarded later.  Better not
+   to generate it in the first place.
+
+   Moreover, if we simplify this implication more than once
+   (e.g. because we can't solve it completely on the first iteration
+   of simpl_looop), we'll generate all the same bindings AGAIN!
+
+Easy solution: take advantage of the work we are doing to track dead
+(unused) Givens, and use it to prune the Given bindings too.  This is
+all done by neededEvVars.
+
+This led to a remarkable 25% overall compiler allocation decrease in
+test T12227.
+
+But we don't get to discard all redundant equality superclasses, alas;
+see Trac #15205.
 
-{-
 Note [Tracking redundant constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With Opt_WarnRedundantConstraints, GHC can report which
@@ -1586,18 +1819,16 @@ works:
 
 ----- How tracking works
 
+* The ic_need fields of an Implic records in-scope (given) evidence
+  variables bound by the context, that were needed to solve this
+  implication (so far).  See the declaration of Implication.
+
 * When the constraint solver finishes solving all the wanteds in
   an implication, it sets its status to IC_Solved
 
   - The ics_dead field, of IC_Solved, records the subset of this
     implication's ic_given that are redundant (not needed).
 
-  - The ics_need field of IC_Solved then records all the
-    in-scope (given) evidence variables bound by the context, that
-    were needed to solve this implication, including all its nested
-    implications.  (We remove the ic_given of this implication from
-    the set, of course.)
-
 * We compute which evidence variables are needed by an implication
   in setImplicationStatus.  A variable is needed if
     a) it is free in the RHS of a Wanted EvBind,
@@ -1680,38 +1911,49 @@ we'll get more Givens (a unification is like adding a Given) to
 allow the implication to make progress.
 -}
 
-promoteTyVar :: TcLevel -> TcTyVar  -> TcM Bool
+promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar)
 -- When we float a constraint out of an implication we must restore
--- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
 -- Return True <=> we did some promotion
+-- Also returns either the original tyvar (no promotion) or the new one
 -- See Note [Promoting unification variables]
-promoteTyVar tclvl tv
-  | isFloatedTouchableMetaTyVar tclvl tv
-  = do { cloned_tv <- TcM.cloneMetaTyVar tv
-       ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
-       ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)
-       ; return True }
-  | otherwise
-  = return False
-
-promoteTyVarTcS :: TcLevel -> TcTyVar  -> TcS ()
+promoteTyVar tv
+  = do { tclvl <- TcM.getTcLevel
+       ; if (isFloatedTouchableMetaTyVar tclvl tv)
+         then do { cloned_tv <- TcM.cloneMetaTyVar tv
+                 ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+                 ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)
+                 ; return (True, rhs_tv) }
+         else return (False, tv) }
+
+-- Returns whether or not *any* tyvar is defaulted
+promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet)
+promoteTyVarSet tvs
+  = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs)
+           -- non-determinism is OK because order of promotion doesn't matter
+
+       ; return (or bools, mkVarSet tyvars) }
+
+promoteTyVarTcS :: TcTyVar  -> TcS ()
 -- When we float a constraint out of an implication we must restore
--- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
 -- See Note [Promoting unification variables]
 -- We don't just call promoteTyVar because we want to use unifyTyVar,
 -- not writeMetaTyVar
-promoteTyVarTcS tclvl tv
-  | isFloatedTouchableMetaTyVar tclvl tv
-  = do { cloned_tv <- TcS.cloneMetaTyVar tv
-       ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
-       ; unifyTyVar tv (mkTyVarTy rhs_tv) }
-  | otherwise
-  = return ()
+promoteTyVarTcS tv
+  = do { tclvl <- TcS.getTcLevel
+       ; when (isFloatedTouchableMetaTyVar tclvl tv) $
+         do { cloned_tv <- TcS.cloneMetaTyVar tv
+            ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+            ; unifyTyVar tv (mkTyVarTy rhs_tv) } }
 
 -- | Like 'defaultTyVar', but in the TcS monad.
 defaultTyVarTcS :: TcTyVar -> TcS Bool
 defaultTyVarTcS the_tv
   | isRuntimeRepVar the_tv
+  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar
+                             -- never with a type; c.f. TcMType.defaultTyVar
+                             -- See Note [Kind generalisation and TyVarTvs]
   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
        ; unifyTyVar the_tv liftedRepTy
        ; return True }
@@ -1726,10 +1968,9 @@ approximateWC float_past_equalities wc
   where
     float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
     float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
-      = filterBag is_floatable simples `unionBags`
+      = filterBag (is_floatable trapping_tvs) simples `unionBags`
         do_bag (float_implic trapping_tvs) implics
       where
-        is_floatable ct = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs
 
     float_implic :: TcTyCoVarSet -> Implication -> Cts
     float_implic trapping_tvs imp
@@ -1739,9 +1980,16 @@ approximateWC float_past_equalities wc
       = emptyCts    -- See (1) under Note [ApproximateWC]
       where
         new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
+
     do_bag :: (a -> Bag c) -> Bag a -> Bag c
     do_bag f = foldrBag (unionBags.f) emptyBag
 
+    is_floatable skol_tvs ct
+       | isGivenCt ct     = False
+       | isHoleCt ct      = False
+       | insolubleEqCt ct = False
+       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
 {- Note [ApproximateWC]
 ~~~~~~~~~~~~~~~~~~~~~~~
 approximateWC takes a constraint, typically arising from the RHS of a
@@ -1830,7 +2078,7 @@ When we are inferring a type, we simplify the constraint, and then use
 approximateWC to produce a list of candidate constraints.  Then we MUST
 
   a) Promote any meta-tyvars that have been floated out by
-     approximateWC, to restore invariant (MetaTvInv) described in
+     approximateWC, to restore invariant (WantedInv) described in
      Note [TcLevel and untouchable type variables] in TcType.
 
   b) Default the kind of any meta-tyvars that are not mentioned in
@@ -1847,8 +2095,8 @@ Note [Promoting unification variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we float an equality out of an implication we must "promote" free
 unification variables of the equality, in order to maintain Invariant
-(MetaTvInv) from Note [TcLevel and untouchable type variables] in TcType.  for the
-leftover implication.
+(WantedInv) from Note [TcLevel and untouchable type variables] in
+TcType.  for the leftover implication.
 
 This is absolutely necessary. Consider the following example. We start
 with two implications and a class with a functional dependency.
@@ -1938,7 +2186,7 @@ no evidence for a fundep equality), but equality superclasses do matter (since
 they carry evidence).
 -}
 
-floatEqualities :: [TcTyVar] -> Bool
+floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool
                 -> WantedConstraints
                 -> TcS (Cts, WantedConstraints)
 -- Main idea: see Note [Float Equalities out of Implications]
@@ -1955,7 +2203,8 @@ floatEqualities :: [TcTyVar] -> Bool
 --
 -- Subtleties: Note [Float equalities from under a skolem binding]
 --             Note [Skolem escape]
-floatEqualities skols no_given_eqs
+--             Note [What prevents a constraint from floating]
+floatEqualities skols given_ids ev_binds_var no_given_eqs
                 wanteds@(WC { wc_simple = simples })
   | not no_given_eqs  -- There are some given equalities, so don't float
   = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
@@ -1966,45 +2215,77 @@ floatEqualities skols no_given_eqs
          -- variables, and we /must/ see them.  Otherwise we may float
          -- constraints that mention the skolems!
          simples <- TcS.zonkSimples simples
+       ; binds   <- TcS.getTcEvBindsMap ev_binds_var
 
        -- Now we can pick the ones to float
-       ; let (float_eqs, remaining_simples) = partitionBag (usefulToFloat skol_set) simples
-             skol_set = mkVarSet skols
+       -- The constraints are un-flattened and de-canonicalised
+       ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples
+
+             seed_skols = mkVarSet skols     `unionVarSet`
+                          mkVarSet given_ids `unionVarSet`
+                          foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
+                          foldEvBindMap add_one_bind emptyVarSet binds
+             -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
+             -- Include the EvIds of any non-floating constraints
+
+             extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols
+                 -- extended_skols contains the EvIds of all the trapped constraints
+                 -- See Note [What prevents a constraint from floating] (3)
+
+             (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols)
+                                                  candidate_eqs
+
+             remaining_simples = no_float_cts `andCts` no_flt_eqs
 
        -- Promote any unification variables mentioned in the floated equalities
        -- See Note [Promoting unification variables]
-       ; outer_tclvl <- TcS.getTcLevel
-       ; mapM_ (promoteTyVarTcS outer_tclvl)
-               (tyCoVarsOfCtsList float_eqs)
+       ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs)
 
        ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
+                                          , text "Extended skols =" <+> ppr extended_skols
                                           , text "Simples =" <+> ppr simples
-                                          , text "Floated eqs =" <+> ppr float_eqs])
-       ; return ( float_eqs
-                , wanteds { wc_simple = remaining_simples } ) }
-
-usefulToFloat :: VarSet -> Ct -> Bool
-usefulToFloat skol_set ct   -- The constraint is un-flattened and de-canonicalised
-  = is_meta_var_eq pred &&
-    (tyCoVarsOfType pred `disjointVarSet` skol_set)
+                                          , text "Candidate eqs =" <+> ppr candidate_eqs
+                                          , text "Floated eqs =" <+> ppr flt_eqs])
+       ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }
+
   where
-    pred = ctPred ct
+    add_one_bind :: EvBind -> VarSet -> VarSet
+    add_one_bind bind acc = extendVarSet acc (evBindVar bind)
 
-      -- Float out alpha ~ ty, or ty ~ alpha
-      -- which might be unified outside
-      -- See Note [Which equalities to float]
-    is_meta_var_eq pred
-      | EqPred NomEq ty1 ty2 <- classifyPredType pred
+    add_non_flt_ct :: Ct -> VarSet -> VarSet
+    add_non_flt_ct ct acc | isDerivedCt ct = acc
+                          | otherwise      = extendVarSet acc (ctEvId ct)
+
+    is_floatable :: VarSet -> Ct -> Bool
+    is_floatable skols ct
+      | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols)
+      | otherwise      = not (ctEvId ct `elemVarSet` skols)
+
+    add_captured_ev_ids :: Cts -> VarSet -> VarSet
+    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts
+       where
+         extra_skol ct acc
+           | isDerivedCt ct                           = acc
+           | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct)
+           | otherwise                                = acc
+
+    -- Identify which equalities are candidates for floating
+    -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside
+    -- See Note [Which equalities to float]
+    is_float_eq_candidate ct
+      | pred <- ctPred ct
+      , EqPred NomEq ty1 ty2 <- classifyPredType pred
+      , typeKind ty1 `tcEqType` typeKind ty2
       = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of
-          (Just tv1, _) -> float_tv_eq tv1 ty2
-          (_, Just tv2) -> float_tv_eq tv2 ty1
+          (Just tv1, _) -> float_tv_eq_candidate tv1 ty2
+          (_, Just tv2) -> float_tv_eq_candidate tv2 ty1
           _             -> False
-      | otherwise
-      = False
+      | otherwise = False
 
-    float_tv_eq tv1 ty2  -- See Note [Which equalities to float]
+    float_tv_eq_candidate tv1 ty2  -- See Note [Which equalities to float]
       =  isMetaTyVar tv1
-      && (not (isSigTyVar tv1) || isTyVarTy ty2)
+      && (not (isTyVarTyVar tv1) || isTyVarTy ty2)
+
 
 {- Note [Float equalities from under a skolem binding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2033,16 +2314,31 @@ Note [Which equalities to float]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Which equalities should we float?  We want to float ones where there
 is a decent chance that floating outwards will allow unification to
-happen.  In particular:
-
-   Float out equalities of form (alpha ~ ty) or (ty ~ alpha), where
+happen.  In particular, float out equalities that are:
 
+* Of form (alpha ~# ty) or (ty ~# alpha), where
    * alpha is a meta-tyvar.
-
-   * And 'alpha' is not a SigTv with 'ty' being a non-tyvar.  In that
+   * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that
      case, floating out won't help either, and it may affect grouping
      of error messages.
 
+* Homogeneous (both sides have the same kind). Why only homogeneous?
+  Because heterogeneous equalities have derived kind equalities.
+  See Note [Equalities with incompatible kinds] in TcCanonical.
+  If we float out a hetero equality, then it will spit out the same
+  derived kind equality again, which might create duplicate error
+  messages.
+
+  Instead, we do float out the kind equality (if it's worth floating
+  out, as above). If/when we solve it, we'll be able to rewrite the
+  original hetero equality to be homogeneous, and then perhaps make
+  progress / float it out. The duplicate error message was spotted in
+  typecheck/should_fail/T7368.
+
+* Nominal.  No point in floating (alpha ~R# ty), because we do not
+  unify representational equalities even if alpha is touchable.
+  See Note [Do not unify representational equalities] in TcInteract.
+
 Note [Skolem escape]
 ~~~~~~~~~~~~~~~~~~~~
 You might worry about skolem escape with all this floating.
@@ -2059,6 +2355,38 @@ skolem has escaped!
 But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]
 to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.
 
+Note [What prevents a constraint from floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What /prevents/ a constraint from floating?  If it mentions one of the
+"bound variables of the implication".  What are they?
+
+The "bound variables of the implication" are
+
+  1. The skolem type variables `ic_skols`
+
+  2. The "given" evidence variables `ic_given`.  Example:
+         forall a. (co :: t1 ~# t2) =>  [W] co2 : (a ~# b |> co)
+     Here 'co' is bound
+
+  3. The binders of all evidence bindings in `ic_binds`. Example
+         forall a. (d :: t1 ~ t2)
+            EvBinds { (co :: t1 ~# t2) = superclass-sel d }
+            => [W] co2 : (a ~# b |> co)
+     Here `co` is gotten by superclass selection from `d`, and the
+     wanted constraint co2 must not float.
+
+  4. And the evidence variable of any equality constraint (incl
+     Wanted ones) whose type mentions a bound variable.  Example:
+        forall k. [W] co1 :: t1 ~# t2 |> co2
+                  [W] co2 :: k ~# *
+     Here, since `k` is bound, so is `co2` and hence so is `co1`.
+
+Here (1,2,3) are handled by the "seed_skols" calculation, and
+(4) is done by the transCloVarSet call.
+
+The possible dependence on givens, and evidence bindings, is more
+subtle than we'd realised at first.  See Trac #14584.
+
 
 *********************************************************************************
 *                                                                               *
@@ -2101,7 +2429,8 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
   = []
   | otherwise
   = [ (tv, map fstOf3 group)
-    | group@((_,_,tv):_) <- unary_groups
+    | group'@((_,_,tv) :| _) <- unary_groups
+    , let group = toList group'
     , defaultable_tyvar tv
     , defaultable_classes (map sndOf3 group) ]
   where
@@ -2109,9 +2438,9 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
     (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
     unary_groups           = equivClasses cmp_tv unaries
 
-    unary_groups :: [[(Ct, Class, TcTyVar)]]  -- (C tv) constraints
-    unaries      ::  [(Ct, Class, TcTyVar)]   -- (C tv) constraints
-    non_unaries  :: [Ct]                      -- and *other* constraints
+    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints
+    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints
+    non_unaries  :: [Ct]                            -- and *other* constraints
 
         -- Finds unary type-class constraints
         -- But take account of polykinded classes like Typeable,
@@ -2177,10 +2506,8 @@ disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
     try_group
       | Just subst <- mb_subst
       = do { lcl_env <- TcS.getLclEnv
-           ; let loc = CtLoc { ctl_origin = GivenOrigin UnkSkol
-                             , ctl_env    = lcl_env
-                             , ctl_t_or_k = Nothing
-                             , ctl_depth  = initialSubGoalDepth }
+           ; tc_lvl <- TcS.getTcLevel
+           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env
            ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)
                                 wanteds
            ; fmap isEmptyWC $
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 6d687b6bcd..c26ba0d90b 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -31,8 +31,11 @@ module TcSplice(
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import Annotations
+import Finder
 import Name
 import TcRnMonad
 import TcType
@@ -43,6 +46,7 @@ import SrcLoc
 import THNames
 import TcUnify
 import TcEnv
+import FileCleanup ( newTempName, TempFileLifetime(..) )
 
 import Control.Monad
 
@@ -52,6 +56,7 @@ import GHCi
 import HscMain
         -- These imports are the reason that TcSplice
         -- is very high up the module hierarchy
+import FV
 import RnSplice( traceSplice, SpliceInfo(..) )
 import RdrName
 import HscTypes
@@ -64,7 +69,6 @@ import RnTypes
 import TcHsSyn
 import TcSimplify
 import Type
-import Kind
 import NameSet
 import TcMType
 import TcHsType
@@ -97,7 +101,7 @@ import GHC.Serialized
 import ErrUtils
 import Util
 import Unique
-import VarSet           ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet )
+import VarSet
 import Data.List        ( find )
 import Data.Maybe
 import FastString
@@ -107,6 +111,7 @@ import DynFlags
 import Panic
 import Lexeme
 import qualified EnumSet
+import Plugins
 
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
@@ -135,8 +140,8 @@ import GHC.Exts         ( unsafeCoerce# )
 ************************************************************************
 -}
 
-tcTypedBracket   :: HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
-tcUntypedBracket :: HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
+tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
                  -> TcM (HsExpr GhcTcId)
 tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTcId)
         -- None of these functions add constraints to the LIE
@@ -157,7 +162,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
 
 -- See Note [How brackets and nested splices are handled]
 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
-tcTypedBracket brack@(TExpBr expr) res_ty
+tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
   = addErrCtxt (quotationCtxtDoc brack) $
     do { cur_stage <- getStage
        ; ps_ref <- newMutVar []
@@ -176,30 +181,33 @@ tcTypedBracket brack@(TExpBr expr) res_ty
        ; ps' <- readMutVar ps_ref
        ; texpco <- tcLookupId unsafeTExpCoerceName
        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
+                       rn_expr
                        (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
-                                              (noLoc (HsTcBracketOut brack ps'))))
+                                      (noLoc (HsTcBracketOut noExt brack ps'))))
                        meta_ty res_ty }
-tcTypedBracket other_brack _
+tcTypedBracket _ other_brack _
   = pprPanic "tcTypedBracket" (ppr other_brack)
 
 -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
-tcUntypedBracket brack ps res_ty
+tcUntypedBracket rn_expr brack ps res_ty
   = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
        ; ps' <- mapM tcPendingSplice ps
        ; meta_ty <- tcBrackTy brack
        ; traceTc "tc_bracket done untyped" (ppr meta_ty)
        ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
-                       (HsTcBracketOut brack ps') meta_ty res_ty }
+                       rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }
 
 ---------------
 tcBrackTy :: HsBracket GhcRn -> TcM TcType
-tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName  -- Result type is Var (not Q-monadic)
-tcBrackTy (ExpBr _)   = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
-tcBrackTy (TypBr _)   = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcBrackTy (DecBrG _)  = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcBrackTy (PatBr _)   = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
-tcBrackTy (DecBrL _)  = panic "tcBrackTy: Unexpected DecBrL"
-tcBrackTy (TExpBr _)  = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (VarBr {})  = tcMetaTy nameTyConName
+                                           -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"
 
 ---------------
 tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
@@ -427,7 +435,7 @@ When a variable is used, we compare
 ************************************************************************
 -}
 
-tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty
+tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty
   = addErrCtxt (spliceCtxtDoc splice) $
     setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
@@ -577,8 +585,9 @@ runAnnotation target expr = do
               ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
               ; let specialised_to_annotation_wrapper_expr
                       = L loc (mkHsWrap wrapper
-                                        (HsVar (L loc to_annotation_wrapper_id)))
-              ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
+                                 (HsVar noExt (L loc to_annotation_wrapper_id)))
+              ; return (L loc (HsApp noExt
+                                specialised_to_annotation_wrapper_expr expr')) }
 
     -- Run the appropriately wrapped expression to get the value of
     -- the annotation and its dictionaries. The return value is of
@@ -726,10 +735,13 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- in type-correct programs.
         ; failIfErrsM
 
+        -- run plugins
+        ; hsc_env <- getTopEnv
+        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
+
         -- Desugar
-        ; ds_expr <- initDsTc (dsLExpr expr)
+        ; ds_expr <- initDsTc (dsLExpr expr')
         -- Compile and link it; might fail if linking fails
-        ; hsc_env <- getTopEnv
         ; src_span <- getSrcSpanM
         ; traceTc "About to run (desugared)" (ppr ds_expr)
         ; either_hval <- tryM $ liftIO $
@@ -868,31 +880,36 @@ instance TH.Quasi TcM where
         -- the recovery action is chosen.  Otherwise
         -- we'll only fail higher up.
   qRecover recover main = tryTcDiscardingErrs recover main
-  qRunIO io = liftIO io
 
   qAddDependentFile fp = do
     ref <- fmap tcg_dependent_files getGblEnv
     dep_files <- readTcRef ref
     writeTcRef ref (fp:dep_files)
 
+  qAddTempFile suffix = do
+    dflags <- getDynFlags
+    liftIO $ newTempName dflags TFL_GhcSession suffix
+
   qAddTopDecls thds = do
       l <- getSrcSpanM
       let either_hval = convertToHsDecls l thds
       ds <- case either_hval of
-              Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
+              Left exn -> failWithTc $
+                hang (text "Error in a declaration passed to addTopDecls:")
+                   2 exn
               Right ds -> return ds
       mapM_ (checkTopDecl . unLoc) ds
       th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
       updTcRef th_topdecls_var (\topds -> ds ++ topds)
     where
       checkTopDecl :: HsDecl GhcPs -> TcM ()
-      checkTopDecl (ValD binds)
+      checkTopDecl (ValD _ binds)
         = mapM_ bindName (collectHsBindBinders binds)
-      checkTopDecl (SigD _)
+      checkTopDecl (SigD _ _)
         = return ()
-      checkTopDecl (AnnD _)
+      checkTopDecl (AnnD _ _)
         = return ()
-      checkTopDecl (ForD (ForeignImport { fd_name = L _ name }))
+      checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
         = bindName name
       checkTopDecl _
         = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
@@ -908,15 +925,31 @@ instance TH.Quasi TcM where
           hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
 
-  qAddForeignFile lang str = do
+  qAddForeignFilePath lang fp = do
     var <- fmap tcg_th_foreign_files getGblEnv
-    updTcRef var ((lang, str) :)
+    updTcRef var ((lang, fp) :)
 
   qAddModFinalizer fin = do
       r <- liftIO $ mkRemoteRef fin
       fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
       addModFinalizerRef fref
 
+  qAddCorePlugin plugin = do
+      hsc_env <- env_top <$> getEnv
+      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
+      let err = hang
+            (text "addCorePlugin: invalid plugin module "
+               <+> text (show plugin)
+            )
+            2
+            (text "Plugins in the current package can't be specified.")
+      case r of
+        Found {} -> addErr err
+        FoundMultiple {} -> addErr err
+        _ -> return ()
+      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+      updTcRef th_coreplugins_var (plugin:)
+
   qGetQ :: forall a. Typeable a => TcM (Maybe a)
   qGetQ = do
       th_state_var <- fmap tcg_th_state getGblEnv
@@ -1098,11 +1131,13 @@ handleTHMessage msg = case msg of
   ReifyModule m -> wrapTHResult $ TH.qReifyModule m
   ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
   AddModFinalizer r -> do
     hsc_env <- env_top <$> getEnv
     wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
+  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
-  AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str
+  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
   ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
   _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
@@ -1137,14 +1172,18 @@ reifyInstances th_nm th_tys
         ; let tv_rdrs = freeKiTyVarsAllVars free_vars
           -- Rename  to HsType Name
         ; ((tv_names, rn_ty), _fvs)
-            <- bindLRdrNames tv_rdrs $ \ tv_names ->
+            <- checkNoErrs $ -- If there are out-of-scope Names here, then we
+                             -- must error before proceeding to typecheck the
+                             -- renamed type, as that will result in GHC
+                             -- internal errors (#13837).
+               bindLRdrNames tv_rdrs $ \ tv_names ->
                do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
                   ; return ((tv_names, rn_ty), fvs) }
         ; (_tvs, ty)
-            <- solveEqualities $
-               tcImplicitTKBndrsType tv_names $
+            <- failIfEmitsConstraints $  -- avoid error cascade if there are unsolved
+               tcImplicitTKBndrs ReifySkol tv_names $
                fst <$> tcLHsType rn_ty
-        ; ty <- zonkTcTypeToType emptyZonkEnv ty
+        ; ty <- zonkTcTypeToType ty
                 -- Substitute out the meta type variables
                 -- In particular, the type might have kind
                 -- variables inside it (Trac #7477)
@@ -1352,7 +1391,7 @@ reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
        ; rhs'  <- reifyType rhs
        ; return (TH.TySynEqn annot_th_lhs rhs') }
   where
-    fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
+    fam_tvs = tyConVisibleTyVars fam_tc
 
 reifyTyCon :: TyCon -> TcM TH.Info
 reifyTyCon tc
@@ -1376,7 +1415,7 @@ reifyTyCon tc
                    Nothing   -> (TH.KindSig kind', Nothing)
                    Just name ->
                      let thName   = reifyName name
-                         injAnnot = familyTyConInjectivityInfo tc
+                         injAnnot = tyConInjectivityInfo tc
                          sig = TH.TyVarSig (TH.KindedTV thName kind')
                          inj = case injAnnot of
                                  NotInjective -> Nothing
@@ -1386,7 +1425,7 @@ reifyTyCon tc
                                      injRHS = map (reifyName . tyVarName)
                                                   (filterByList ms tvs)
                      in (sig, inj)
-       ; tvs' <- reifyTyVars tvs (Just tc)
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
        ; let tfHead =
                TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
        ; if isOpenTypeFamilyTyCon tc
@@ -1403,20 +1442,19 @@ reifyTyCon tc
                       []) } }
 
   | isDataFamilyTyCon tc
-  = do { let tvs      = tyConTyVars tc
-             res_kind = tyConResKind tc
+  = do { let res_kind = tyConResKind tc
 
        ; kind' <- fmap Just (reifyKind res_kind)
 
-       ; tvs' <- reifyTyVars tvs (Just tc)
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
        ; fam_envs <- tcGetFamInstEnvs
        ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
        ; return (TH.FamilyI
                        (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
 
-  | Just (tvs, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
+  | Just (_, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
   = do { rhs' <- reifyType rhs
-       ; tvs' <- reifyTyVars tvs (Just tc)
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
        ; return (TH.TyConI
                    (TH.TySynD (reifyName tc) tvs' rhs'))
        }
@@ -1425,10 +1463,9 @@ reifyTyCon tc
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
         ; let tvs      = tyConTyVars tc
               dataCons = tyConDataCons tc
-              -- see Note [Reifying GADT data constructors]
-              isGadt   = any (not . null . dataConEqSpec) dataCons
+              isGadt   = isGadtSyntaxTyCon tc
         ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
-        ; r_tvs <- reifyTyVars tvs (Just tc)
+        ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
         ; let name = reifyName tc
               deriv = []        -- Don't know about deriving
               decl | isNewTyCon tc =
@@ -1438,13 +1475,13 @@ reifyTyCon tc
         ; return (TH.TyConI decl) }
 
 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
--- For GADTs etc, see Note [Reifying GADT data constructors]
 reifyDataCon isGadtDataCon tys dc
   = do { let -- used for H98 data constructors
              (ex_tvs, theta, arg_tys)
                  = dataConInstSig dc tys
              -- used for GADTs data constructors
-             (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)
+             g_user_tvs' = dataConUserTyVars dc
+             (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
                  = dataConFullSig dc
              (srcUnpks, srcStricts)
                  = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
@@ -1454,7 +1491,15 @@ reifyDataCon isGadtDataCon tys dc
              -- Universal tvs present in eq_spec need to be filtered out, as
              -- they will not appear anywhere in the type.
              eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
-             g_unsbst_univ_tvs = filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
+
+       ; (univ_subst, _)
+              -- See Note [Freshen reified GADT constructors' universal tyvars]
+           <- freshenTyVarBndrs $
+              filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
+       ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'
+             g_theta   = substTys tvb_subst g_theta'
+             g_arg_tys = substTys tvb_subst g_arg_tys'
+             g_res_ty  = substTy  tvb_subst g_res_ty'
 
        ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
 
@@ -1481,34 +1526,42 @@ reifyDataCon isGadtDataCon tys dc
               | otherwise ->
                   return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
 
-       ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
-                                                 , g_theta )
-                               | otherwise     = ( ex_tvs, theta )
+       ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
+                               | otherwise     = ASSERT( all isTyVar ex_tvs )
+                                                 -- no covars for haskell syntax
+                                                 (ex_tvs, theta)
              ret_con | null ex_tvs' && null theta' = return main_con
                      | otherwise                   = do
                          { cxt <- reifyCxt theta'
-                         ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
+                         ; ex_tvs'' <- reifyTyVars ex_tvs'
                          ; return (TH.ForallC ex_tvs'' cxt main_con) }
        ; ASSERT( arg_tys `equalLength` dcdBangs )
          ret_con }
 
--- Note [Reifying GADT data constructors]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- At this point in the compilation pipeline we have no way of telling whether a
--- data type was declared as a H98 data type or as a GADT.  We have to rely on
--- heuristics here.  We look at dcEqSpec field of all data constructors in a
--- data type declaration.  If at least one data constructor has non-empty
--- dcEqSpec this means that the data type must have been declared as a GADT.
--- Consider these declarations:
---
---   data T a where
---      MkT :: forall a. (a ~ Int) => T a
---
---   data T a where
---      MkT :: T Int
---
--- First declaration will be reified as a GADT.  Second declaration will be
--- reified as a normal H98 data type declaration.
+{-
+Note [Freshen reified GADT constructors' universal tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose one were to reify this GADT:
+
+  data a :~: b where
+    Refl :: forall a b. (a ~ b) => a :~: b
+
+We ought to be careful here about the uniques we give to the occurrences of `a`
+and `b` in this definition. That is because in the original DataCon, all uses
+of `a` and `b` have the same unique, since `a` and `b` are both universally
+quantified type variables--that is, they are used in both the (:~:) tycon as
+well as in the constructor type signature. But when we turn the DataCon
+definition into the reified one, the `a` and `b` in the constructor type
+signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
+
+While it wouldn't technically be *wrong* per se to re-use the same uniques for
+`a` and `b` across these two different scopes, it's somewhat annoying for end
+users of Template Haskell, since they wouldn't be able to rely on the
+assumption that all TH names have globally distinct uniques (#13885). For this
+reason, we freshen the universally quantified tyvars that go into the reified
+GADT constructor type signature to give them distinct uniques from their
+counterparts in the tycon.
+-}
 
 ------------------------------
 reifyClass :: Class -> TcM TH.Info
@@ -1518,20 +1571,24 @@ reifyClass cls
         ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
         ; assocTys <- concatMapM reifyAT ats
         ; ops <- concatMapM reify_op op_stuff
-        ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
+        ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
         ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
         ; return (TH.ClassI dec insts) }
   where
-    (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
+    (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
     reify_op (op, def_meth)
-      = do { ty <- reifyType (idType op)
+      = do { let (_, _, ty) = tcSplitMethodTy (idType op)
+               -- Use tcSplitMethodTy to get rid of the extraneous class
+               -- variables and predicates at the beginning of op's type
+               -- (see #15551).
+           ; ty' <- reifyType ty
            ; let nm' = reifyName op
            ; case def_meth of
                 Just (_, GenericDM gdm_ty) ->
                   do { gdm_ty' <- reifyType gdm_ty
-                     ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
-                _ -> return [TH.SigD nm' ty] }
+                     ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
+                _ -> return [TH.SigD nm' ty'] }
 
     reifyAT :: ClassATItem -> TcM [TH.Dec]
     reifyAT (ATI tycon def) = do
@@ -1590,7 +1647,7 @@ reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
 reifyClassInstances cls insts
   = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
   where
-    tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
+    tvs = tyConVisibleTyVars (classTyCon cls)
 
 reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
                               -- includes only *visible* tvs
@@ -1618,7 +1675,7 @@ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
 reifyFamilyInstances fam_tc fam_insts
   = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
   where
-    fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
+    fam_tvs = tyConVisibleTyVars fam_tc
 
 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
                               -- includes only *visible* tvs
@@ -1653,8 +1710,7 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
                  eta_expanded_tvs = mkTyVarTys fam_tvs `chkAppend` etad_tys
                  eta_expanded_lhs = lhs `chkAppend` etad_tys
                  dataCons         = tyConDataCons rep_tc
-                 -- see Note [Reifying GADT data constructors]
-                 isGadt   = any (not . null . dataConEqSpec) dataCons
+                 isGadt           = isGadtSyntaxTyCon rep_tc
            ; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons
            ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
            ; th_tys <- reifyTypes types_only
@@ -1670,6 +1726,9 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
 ------------------------------
 reifyType :: TyCoRep.Type -> TcM TH.Type
 -- Monadic only because of failure
+reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT
+  -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
+  -- with Constraint (#14869).
 reifyType ty@(ForAllTy {})  = reify_for_all ty
 reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }
 reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
@@ -1678,14 +1737,14 @@ reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `T
 reifyType ty@(FunTy t1 t2)
   | isPredTy t1 = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
   | otherwise   = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
-reifyType ty@(CastTy {})    = noTH (sLit "kind casts") (ppr ty)
+reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH
 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
 
 reify_for_all :: TyCoRep.Type -> TcM TH.Type
 reify_for_all ty
   = do { cxt' <- reifyCxt cxt;
        ; tau' <- reifyType tau
-       ; tvs' <- reifyTyVars tvs Nothing
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.ForallT tvs' cxt' tau') }
   where
     (tvs, cxt, tau) = tcSplitSigmaTy ty
@@ -1703,59 +1762,26 @@ reifyPatSynType
 -- signature; see NOTE [Pattern synonym signatures and Template
 -- Haskell]
 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
-  = do { univTyVars' <- reifyTyVars univTyVars Nothing
+  = do { univTyVars' <- reifyTyVars univTyVars
        ; req'        <- reifyCxt req
-       ; exTyVars'   <- reifyTyVars exTyVars Nothing
+       ; exTyVars'   <- reifyTyVars exTyVars
        ; prov'       <- reifyCxt prov
        ; tau'        <- reifyType (mkFunTys argTys resTy)
        ; return $ TH.ForallT univTyVars' req'
                 $ TH.ForallT exTyVars' prov' tau' }
 
 reifyKind :: Kind -> TcM TH.Kind
-reifyKind  ki
-  = do { let (kis, ki') = splitFunTys ki
-       ; ki'_rep <- reifyNonArrowKind ki'
-       ; kis_rep <- mapM reifyKind kis
-       ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
-  where
-    reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
-                        | isConstraintKind k = return TH.ConstraintT
-    reifyNonArrowKind (TyVarTy v)            = return (TH.VarT (reifyName v))
-    reifyNonArrowKind (FunTy _ k)            = reifyKind k
-    reifyNonArrowKind (ForAllTy _ k)         = reifyKind k
-    reifyNonArrowKind (TyConApp kc kis)      = reify_kc_app kc kis
-    reifyNonArrowKind (AppTy k1 k2)          = do { k1' <- reifyKind k1
-                                                  ; k2' <- reifyKind k2
-                                                  ; return (TH.AppT k1' k2')
-                                                  }
-    reifyNonArrowKind k                      = noTH (sLit "this kind") (ppr k)
-
-reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
-reify_kc_app kc kis
-  = fmap (mkThAppTs r_kc) (mapM reifyKind vis_kis)
-  where
-    r_kc | isTupleTyCon kc          = TH.TupleT (tyConArity kc)
-         | kc `hasKey` listTyConKey = TH.ListT
-         | otherwise                = TH.ConT (reifyName kc)
-
-    vis_kis = filterOutInvisibleTypes kc kis
+reifyKind = reifyType
 
 reifyCxt :: [PredType] -> TcM [TH.Pred]
-reifyCxt   = mapM reifyPred
+reifyCxt   = mapM reifyType
 
 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 
-reifyTyVars :: [TyVar]
-            -> Maybe TyCon  -- the tycon if the tycovars are from a tycon.
-                            -- Used to detect which tvs are implicit.
-            -> TcM [TH.TyVarBndr]
-reifyTyVars tvs m_tc = mapM reify_tv tvs'
+reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
+reifyTyVars tvs = mapM reify_tv tvs
   where
-    tvs' = case m_tc of
-             Just tc -> filterOutInvisibleTyVars tc tvs
-             Nothing -> tvs
-
     -- even if the kind is *, we need to include a kind annotation,
     -- in case a poly-kind would be inferred without the annotation.
     -- See #8953 or test th/T8953
@@ -1775,13 +1801,67 @@ For example:
    type instance F Bool = (Proxy :: (* -> *) -> *)
 
 It's hard to figure out where these annotations should appear, so we do this:
-Suppose the tycon is applied to n arguments. We strip off the first n
-arguments of the tycon's kind. If there are any variables left in the result
-kind, we put on a kind annotation. But we must be slightly careful: it's
-possible that the tycon's kind will have fewer than n arguments, in the case
-that the concrete application instantiates a result kind variable with an
-arrow kind. So, if we run out of arguments, we conservatively put on a kind
-annotation anyway. This should be a rare case, indeed. Here is an example:
+Suppose we have a tycon application (T ty1 ... tyn). Assuming that T is not
+oversatured (more on this later), we can assume T's declaration is of the form
+T (tvb1 :: s1) ... (tvbn :: sn) :: p. If any kind variable that
+is free in p is not free in an injective position in tvb1 ... tvbn,
+then we put on a kind annotation, since we would not otherwise be able to infer
+the kind of the whole tycon application.
+
+The injective positions in a tyvar binder are the injective positions in the
+kind of its tyvar, provided the tyvar binder is either:
+
+* Anonymous. For example, in the promoted data constructor '(:):
+
+    '(:) :: forall a. a -> [a] -> [a]
+
+  The second and third tyvar binders (of kinds `a` and `[a]`) are both
+  anonymous, so if we had '(:) 'True '[], then the inferred kinds of 'True and
+  '[] would contribute to the inferred kind of '(:) 'True '[].
+* Has required visibility. For example, in the type family:
+
+    type family Wurble k (a :: k) :: k
+    Wurble :: forall k -> k -> k
+
+  The first tyvar binder (of kind `forall k`) has required visibility, so if
+  we had Wurble (Maybe a) Nothing, then the inferred kind of Maybe a would
+  contribute to the inferred kind of Wurble (Maybe a) Nothing.
+
+An injective position in a type is one that does not occur as an argument to
+a non-injective type constructor (e.g., non-injective type families). See
+injectiveVarsOfType.
+
+How can be sure that this is correct? That is, how can we be sure that in the
+event that we leave off a kind annotation, that one could infer the kind of the
+tycon application from its arguments? It's essentially a proof by induction: if
+we can infer the kinds of every subtree of a type, then the whole tycon
+application will have an inferrable kind--unless, of course, the remainder of
+the tycon application's kind has uninstantiated kind variables.
+
+An earlier implementation of this algorithm only checked if p contained any
+free variables. But this was unsatisfactory, since a datatype like this:
+
+  data Foo = Foo (Proxy '[False, True])
+
+Would be reified like this:
+
+  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool])
+                                     :: [Bool]) :: [Bool]))
+
+Which has a rather excessive amount of kind annotations. With the current
+algorithm, we instead reify Foo to this:
+
+  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool]))))
+
+Since in the case of '[], the kind p is [a], and there are no arguments in the
+kind of '[]. On the other hand, in the case of '(:) True '[], the kind p is
+(forall a. [a]), but a occurs free in the first and second arguments of the
+full kind of '(:), which is (forall a. a -> [a] -> [a]). (See Trac #14060.)
+
+What happens if T is oversaturated? That is, if T's kind has fewer than n
+arguments, in the case that the concrete application instantiates a result
+kind variable with an arrow kind? If we run out of arguments, we do not attach
+a kind annotation. This should be a rare case, indeed. Here is an example:
 
    data T1 :: k1 -> k2 -> *
    data T2 :: k1 -> k2 -> *
@@ -1795,10 +1875,14 @@ Here G's kind is (forall k. k -> k), and the desugared RHS of that last
 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
 the algorithm above, there are 3 arguments to G so we should peel off 3
 arguments in G's kind. But G's kind has only two arguments. This is the
-rare special case, and we conservatively choose to put the annotation
-in.
+rare special case, and we choose not to annotate the application of G with
+a kind signature. After all, we needn't do this, since that instance would
+be reified as:
 
-See #8953 and test th/T8953.
+   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool
+
+So the kind of G isn't ambiguous anymore due to the explicit kind annotation
+on its argument. See #8953 and test th/T8953.
 -}
 
 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
@@ -1817,6 +1901,9 @@ reify_tc_app tc tys
          | isTupleTyCon tc                = if isPromotedDataCon tc
                                             then TH.PromotedTupleT arity
                                             else TH.TupleT arity
+         | tc `hasKey` constraintKindTyConKey
+                                          = TH.ConstraintT
+         | tc `hasKey` funTyConKey        = TH.ArrowT
          | tc `hasKey` listTyConKey       = TH.ListT
          | tc `hasKey` nilDataConKey      = TH.PromotedNilT
          | tc `hasKey` consDataConKey     = TH.PromotedConsT
@@ -1837,19 +1924,16 @@ reify_tc_app tc tys
 
     needs_kind_sig
       | GT <- compareLength tys tc_binders
-      = tcIsTyVarTy tc_res_kind
+      = False
       | otherwise
-      = not . isEmptyVarSet $
-        filterVarSet isTyVar $
-        tyCoVarsOfType $
-        mkTyConKind (dropList tys tc_binders) tc_res_kind
-
-reifyPred :: TyCoRep.PredType -> TcM TH.Pred
-reifyPred ty
-  -- We could reify the invisible parameter as a class but it seems
-  -- nicer to support them properly...
-  | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
-  | otherwise   = reifyType ty
+      = let (dropped_binders, remaining_binders)
+              = splitAtList  tys tc_binders
+            result_kind  = mkTyConKind remaining_binders tc_res_kind
+            result_vars  = tyCoVarsOfType result_kind
+            dropped_vars = fvVarSet $
+                           mapUnionFV injectiveVarsOfBinder dropped_binders
+
+        in not (subVarSet result_vars dropped_vars)
 
 ------------------------------
 reifyName :: NamedThing n => n -> TH.Name
@@ -1967,7 +2051,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
 
 ------------------------------
 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
-mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
+mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
 
 noTH :: LitString -> SDoc -> TcM a
 noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot
index 2aa51c8bcd..be2c67d887 100644
--- a/compiler/typecheck/TcSplice.hs-boot
+++ b/compiler/typecheck/TcSplice.hs-boot
@@ -2,6 +2,8 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module TcSplice where
+
+import GhcPrelude
 import Name
 import HsExpr   ( PendingRnSplice )
 import TcRnTypes( TcM , SpliceType )
@@ -17,11 +19,13 @@ tcSpliceExpr :: HsSplice GhcRn
              -> ExpRhoType
              -> TcM (HsExpr GhcTcId)
 
-tcUntypedBracket :: HsBracket GhcRn
+tcUntypedBracket :: HsExpr GhcRn
+                 -> HsBracket GhcRn
                  -> [PendingRnSplice]
                  -> ExpRhoType
                  -> TcM (HsExpr GhcTcId)
-tcTypedBracket :: HsBracket GhcRn
+tcTypedBracket :: HsExpr GhcRn
+               -> HsBracket GhcRn
                -> ExpRhoType
                -> TcM (HsExpr GhcTcId)
 
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 4e7c99cde8..eafb5b37af 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -10,18 +10,20 @@ TcTyClsDecls: Typecheck type and class declarations
 {-# LANGUAGE TypeFamilies #-}
 
 module TcTyClsDecls (
-        tcTyAndClassDecls, tcAddImplicits,
+        tcTyAndClassDecls,
 
         -- Functions used by TcInstDcls to check
         -- data/type family instance declarations
         kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
-        tcFamTyPats, tcTyFamInstEqn, famTyConShape,
+        tcFamTyPats, tcTyFamInstEqn,
         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
         wrongKindOfFamily, dataConCtxt
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import HscTypes
 import BuildTyCl
@@ -33,7 +35,8 @@ import TcTyDecls
 import TcClassDcl
 import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
 import TcDeriv (DerivInfo)
-import TcUnify
+import TcEvidence  ( tcCoercionKind, isEmptyTcEvBinds )
+import TcUnify     ( checkConstraints )
 import TcHsType
 import TcMType
 import TysWiredIn ( unitTy )
@@ -44,7 +47,6 @@ import FamInstEnv
 import Coercion
 import Type
 import TyCoRep   -- for checkValidRoles
-import Kind
 import Class
 import CoAxiom
 import TyCon
@@ -61,15 +63,20 @@ import Outputable
 import Maybes
 import Unify
 import Util
+import Pair
 import SrcLoc
 import ListSetOps
 import DynFlags
 import Unique
+import ConLike( ConLike(..) )
 import BasicTypes
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Data.List
+import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.Set as Set
+
 
 {-
 ************************************************************************
@@ -147,7 +154,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
   = do { let role_annots = mkRoleAnnotEnv roles
 
            -- Step 1: Typecheck the type/class declarations
-       ; traceTc "-------- tcTyClGroup ------------" empty
+       ; traceTc "---- tcTyClGroup ---- {" empty
        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
        ; tyclss <- tcTyClDecls tyclds role_annots
 
@@ -157,35 +164,33 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
        ; checkSynCycles this_uid tyclss tyclds
        ; traceTc "Done synonym cycle check" (ppr tyclss)
 
-       ; traceTc "Starting family consistency check" (ppr tyclss)
-       ; forM_ tyclss checkRecFamInstConsistency
-       ; traceTc "Done family consistency" (ppr tyclss)
-
            -- Step 2: Perform the validity check on those types/classes
            -- We can do this now because we are done with the recursive knot
            -- Do it before Step 3 (adding implicit things) because the latter
            -- expects well-formed TyCons
        ; traceTc "Starting validity check" (ppr tyclss)
-       ; tyclss <- mapM checkValidTyCl tyclss
+       ; tyclss <- concatMapM checkValidTyCl tyclss
        ; traceTc "Done validity check" (ppr tyclss)
        ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
            -- See Note [Check role annotations in a second pass]
 
+       ; traceTc "---- end tcTyClGroup ---- }" empty
+
            -- Step 3: Add the implicit things;
            -- we want them in the environment because
            -- they may be mentioned in interface files
-       ; tcExtendTyConEnv tyclss $
-    do { gbl_env <- tcAddImplicits tyclss
+       ; gbl_env <- addTyConsToGblEnv tyclss
+
+           -- Step 4: check instance declarations
        ; setGblEnv gbl_env $
-    do {
-            -- Step 4: check instance declarations
-       ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds
+         tcInstDecls1 instds }
 
-       ; return (gbl_env, inst_info, datafam_deriv_info) } } }
+tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"
 
 tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
 tcTyClDecls tyclds role_annots
-  = do {    -- Step 1: kind-check this group and returns the final
+  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]
+    do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
          tc_tycons <- kcTyClGroup tyclds
@@ -203,22 +208,25 @@ tcTyClDecls tyclds role_annots
 
                  -- Populate environment with knot-tied ATyCon for TyCons
                  -- NB: if the decls mention any ill-staged data cons
-                 -- (see Note [Recusion and promoting data constructors])
+                 -- (see Note [Recursion and promoting data constructors])
                  -- we will have failed already in kcTyClGroup, so no worries here
            ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
 
                  -- Also extend the local type envt with bindings giving
-                 -- the (polymorphic) kind of each knot-tied TyCon or Class
+                 -- a TcTyCon for each each knot-tied TyCon or Class
                  -- See Note [Type checking recursive type and class declarations]
-             tcExtendKindEnv (foldl extendEnvWithTcTyCon emptyNameEnv tc_tycons) $
+                 -- and Note [Type environment evolution]
+             tcExtendKindEnvWithTyCons tc_tycons $
 
                  -- Kind and type check declarations for this group
                mapM (tcTyClDecl roles) tyclds
            } }
   where
+    promotion_err_env = mkPromotionErrorEnv tyclds
     ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
                                   , ppr (tyConBinders tc) <> comma
-                                  , ppr (tyConResKind tc) ])
+                                  , ppr (tyConResKind tc)
+                                  , ppr (isTcTyCon tc) ])
 
 zipRecTyClss :: [TcTyCon]
              -> [TyCon]           -- Knot-tied
@@ -286,6 +294,26 @@ support making synonyms of types with higher-rank kinds.  But
 you can always specify a CUSK directly to make this work out.
 See tc269 for an example.
 
+Note [Skip decls with CUSKs in kcLTyClDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+    data T (a :: *) = MkT (S a)   -- Has CUSK
+    data S a = MkS (T Int) (S a)  -- No CUSK
+
+Via getInitialKinds we get
+  T :: * -> *
+  S :: kappa -> *
+
+Then we call kcTyClDecl on each decl in the group, to constrain the
+kind unification variables.  BUT we /skip/ the RHS of any decl with
+a CUSK.  Here we skip the RHS of T, so we eventually get
+  S :: forall k. k -> *
+
+This gets us more polymorphism than we would otherwise get, similar
+(but implemented strangely differently from) the treatment of type
+signatures in value declarations.
+
 Open type families
 ~~~~~~~~~~~~~~~~~~
 This treatment of type synonyms only applies to Haskell 98-style synonyms.
@@ -298,31 +326,169 @@ instances of families altogether in the following. However, we need to include
 the kinds of *associated* families into the construction of the initial kind
 environment. (This is handled by `allDecls').
 
-
 See also Note [Kind checking recursive type and class declarations]
 
--}
+Note [How TcTyCons work]
+~~~~~~~~~~~~~~~~~~~~~~~~
+TcTyCons are used for two distinct purposes
+
+1.  When recovering from a type error in a type declaration,
+    we want to put the erroneous TyCon in the environment in a
+    way that won't lead to more errors.  We use a TcTyCon for this;
+    see makeRecoveryTyCon.
+
+2.  When checking a type/class declaration (in module TcTyClsDecls), we come
+    upon knowledge of the eventual tycon in bits and pieces.
+
+      S1) First, we use getInitialKinds to look over the user-provided
+          kind signature of a tycon (including, for example, the number
+          of parameters written to the tycon) to get an initial shape of
+          the tycon's kind.  We record that shape in a TcTyCon.
+
+      S2) Then, using these initial kinds, we kind-check the body of the
+          tycon (class methods, data constructors, etc.), filling in the
+          metavariables in the tycon's initial kind.
+
+      S3) We then generalize to get the tycon's final, fixed
+          kind. Finally, once this has happened for all tycons in a
+          mutually recursive group, we can desugar the lot.
+
+    For convenience, we store partially-known tycons in TcTyCons, which
+    might store meta-variables. These TcTyCons are stored in the local
+    environment in TcTyClsDecls, until the real full TyCons can be created
+    during desugaring. A desugared program should never have a TcTyCon.
+
+    A challenging piece in all of this is that we end up taking three separate
+    passes over every declaration:
+      - one in getInitialKind (this pass look only at the head, not the body)
+      - one in kcTyClDecls (to kind-check the body)
+      - a final one in tcTyClDecls (to desugar)
+    In the latter two passes, we need to connect the user-written type
+    variables in an LHsQTyVars with the variables in the tycon's
+    inferred kind. Because the tycon might not have a CUSK, this
+    matching up is, in general, quite hard to do.  (Look through the
+    git history between Dec 2015 and Apr 2016 for
+    TcHsType.splitTelescopeTvs!) Instead of trying, we just store the
+    list of type variables to bring into scope, in the
+    tyConScopedTyVars field of the TcTyCon.  These tyvars are brought
+    into scope in kcTyClTyVars and tcTyClTyVars, both in TcHsType.
+
+    In a TcTyCon, everything is zonked after the kind-checking pass (S2).
+
+    See also Note [Type checking recursive type and class declarations].
+
+Note [Check telescope again during generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The telescope check before kind generalisation is useful to catch something
+like this:
+
+  data T a k = MkT (Proxy (a :: k))
+
+Clearly, the k has to come first. Checking for this problem must come before
+kind generalisation, as described in Note [Bad telescopes] in
+TcValidity.
+
+However, we have to check again *after* kind generalisation, to catch something
+like this:
+
+  data SameKind :: k -> k -> Type  -- to force unification
+  data S a (b :: a) (d :: SameKind c b)
+
+Note that c has no explicit binding site. As such, it's quantified by kind
+generalisation. (Note that kcHsTyVarBndrs does not return such variables
+as binders in its returned TcTyCon.) The user-written part of this telescope
+is well-ordered; no earlier variables depend on later ones. However, after
+kind generalisation, we put c up front, like so:
+
+  data S {c :: a} a (b :: a) (d :: SameKind c b)
+
+We now have a problem. We could detect this problem just by looking at the
+free vars of the kinds of the generalised variables (the kvs), but we get
+such a nice error message out of checkValidTelescope that it seems like the
+right thing to do.
+
+Note [Type environment evolution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As we typecheck a group of declarations the type environment evolves.
+Consider for example:
+  data B (a :: Type) = MkB (Proxy 'MkB)
 
+We do the following steps:
+
+  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the
+     type env with promotion errors
+            B   :-> TyConPE
+            MkB :-> DataConPE
+
+  2. kcTyCLGruup
+      - Do getInitialKinds, which will signal a promotion
+        error if B is used in any of the kinds needed to initialse
+        B's kind (e.g. (a :: Type)) here
+
+      - Extend the type env with these initial kinds (monomorphic for
+        decls that lack a CUSK)
+            B :-> TcTyCon <initial kind>
+        (thereby overriding the B :-> TyConPE binding)
+        and do kcLTyClDecl on each decl to get equality constraints on
+        all those inital kinds
+
+      - Generalise the inital kind, making a poly-kinded TcTyCon
+
+  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded
+     TcTyCons, again overriding the promotion-error bindings.
+
+     But note that the data constructor promotion errors are still in place
+     so that (in our example) a use of MkB will sitll be signalled as
+     an error.
+
+  4. Typecheck the decls.
+
+  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons
+
+
+Note [Missed opportunity to retain higher-rank kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In 'kcTyClGroup', there is a missed opportunity to make kind
+inference work in a few more cases.  The idea is analogous
+to Note [Single function non-recursive binding special-case]:
+
+     * If we have an SCC with a single decl, which is non-recursive,
+       instead of creating a unification variable representing the
+       kind of the decl and unifying it with the rhs, we can just
+       read the type directly of the rhs.
+
+     * Furthermore, we can update our SCC analysis to ignore
+       dependencies on declarations which have CUSKs: we don't
+       have to kind-check these all at once, since we can use
+       the CUSK to initialize the kind environment.
+
+Unfortunately this requires reworking a bit of the code in
+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
+
+Note [Don't process associated types in kcLHsQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, we processed associated types in the thing_inside in kcLHsQTyVars,
+but this was wrong -- we want to do ATs sepearately.
+The consequence for not doing it this way is #15142:
+
+  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where
+    type ListToTuple as :: Type
+
+We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify
+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring
+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't
+unified with Type. And then, when we generalize the kind of ListToTuple (which
+indeed has a CUSK, according to the rules), we skolemize the free metavariable
+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,
+because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]
+will unify with Type.
+
+Bottom line: as associated types should have no effect on a CUSK enclosing class,
+we move processing them to a separate action, run after the outer kind has
+been generalized.
+
+-}
 
--- Note [Missed opportunity to retain higher-rank kinds]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In 'kcTyClGroup', there is a missed opportunity to make kind
--- inference work in a few more cases.  The idea is analogous
--- to Note [Single function non-recursive binding special-case]:
---
---      * If we have an SCC with a single decl, which is non-recursive,
---        instead of creating a unification variable representing the
---        kind of the decl and unifying it with the rhs, we can just
---        read the type directly of the rhs.
---
---      * Furthermore, we can update our SCC analysis to ignore
---        dependencies on declarations which have CUSKs: we don't
---        have to kind-check these all at once, since we can use
---        the CUSK to initialize the kind environment.
---
--- Unfortunately this requires reworking a bit of the code in
--- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
---
 kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 
 -- Kind check this group, kind generalize, and return the resulting local env
@@ -332,7 +498,7 @@ kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 -- the arity
 kcTyClGroup decls
   = do  { mod <- getModule
-        ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
+        ; traceTc "---- kcTyClGroup ---- {" (text "module" <+> ppr mod $$ vcat (map ppr decls))
 
           -- Kind checking;
           --    1. Bind kind variables for decls
@@ -340,91 +506,83 @@ kcTyClGroup decls
           --    3. Generalise the inferred kinds
           -- See Note [Kind checking for type and class decls]
 
-        ; lcl_env <- solveEqualities $
-                     do { -- Step 1: Bind kind variables for all decls
-                          initial_kinds <- getInitialKinds decls
-                        ; traceTc "kcTyClGroup: initial kinds" $
-                          ppr initial_kinds
+          -- Step 1: Bind kind variables for all decls
+        ; initial_tcs <- getInitialKinds decls
+        ; traceTc "kcTyClGroup: initial kinds" $
+          ppr_tc_kinds initial_tcs
+
+         -- Step 2: Set extended envt, kind-check the decls
+         -- NB: the environment extension overrides the tycon
+         --     promotion-errors bindings
+         --     See Note [Type environment evolution]
 
-                        -- Step 2: Set extended envt, kind-check the decls
-                        ; tcExtendKindEnv initial_kinds $
-                          do { mapM_ kcLTyClDecl decls
-                             ; getLclEnv } }
+        ; solveEqualities $
+          tcExtendKindEnvWithTyCons initial_tcs $
+          mapM_ kcLTyClDecl decls
 
         -- Step 3: generalisation
         -- Kind checking done for this group
         -- Now we have to kind generalize the flexis
-        ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
+        ; poly_tcs <- mapAndReportM generalise initial_tcs
 
-        ; traceTc "kcTyClGroup result" (vcat (map pp_res res))
-        ; return res }
+        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
+        ; return poly_tcs }
 
   where
-    generalise :: TcTypeEnv -> Name -> TcM TcTyCon
+    ppr_tc_kinds tcs = vcat (map pp_tc tcs)
+    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
+
+    generalise :: TcTyCon -> TcM TcTyCon
     -- For polymorphic things this is a no-op
-    generalise kind_env name
-      = do { let tc = case lookupNameEnv kind_env name of
-                        Just (ATcTyCon tc) -> tc
-                        _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
-                 kc_binders  = tyConBinders tc
-                 kc_res_kind = tyConResKind tc
-                 kc_tyvars   = tyConTyVars tc
-                 kc_flav     = tyConFlavour tc
-           ; kvs <- kindGeneralize (mkTyConKind kc_binders kc_res_kind)
-           ; let all_binders = mkNamedTyConBinders Inferred kvs ++ kc_binders
-
-           ; (env, all_binders') <- zonkTyVarBindersX emptyZonkEnv all_binders
-           ; kc_res_kind'        <- zonkTcTypeToType env kc_res_kind
-
-                      -- Make sure kc_kind' has the final, zonked kind variables
-           ; traceTc "Generalise kind" $
-             vcat [ ppr name, ppr kc_binders, ppr kvs, ppr all_binders, ppr kc_res_kind
-                  , ppr all_binders', ppr kc_res_kind'
-                  , ppr kc_tyvars, ppr (tcTyConScopedTyVars tc)]
-
-           ; return (mkTcTyCon name all_binders' kc_res_kind'
-                               (tcTyConScopedTyVars tc)
-                               kc_flav) }
-
-    generaliseTCD :: TcTypeEnv
-                  -> LTyClDecl GhcRn -> TcM [TcTyCon]
-    generaliseTCD kind_env (L _ decl)
-      | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl
-      = do { first <- generalise kind_env name
-           ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats
-           ; return (first : rest) }
-
-      | FamDecl { tcdFam = fam } <- decl
-      = do { res <- generaliseFamDecl kind_env fam
-           ; return [res] }
+    generalise tc
+      = setSrcSpan (getSrcSpan tc) $
+        addTyConCtxt tc $
+        do { let name = tyConName tc
+           ; tc_binders  <- mapM zonkTcTyVarBinder (tyConBinders tc)
+           ; tc_res_kind <- zonkTcType (tyConResKind tc)
+           ; let scoped_tvs  = tcTyConScopedTyVars tc
+                 user_tyvars = tcTyConUserTyVars tc
 
-      | otherwise
-      = do { res <- generalise kind_env (tcdName decl)
-           ; return [res] }
+              -- See Note [checkValidDependency]
+           ; checkValidDependency tc_binders tc_res_kind
 
-    generaliseFamDecl :: TcTypeEnv
-                      -> FamilyDecl GhcRn -> TcM TcTyCon
-    generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
-      = generalise kind_env name
+               -- See Note [Bad telescopes] in TcValidity
+           ; checkValidTelescope tc_binders user_tyvars empty
+           ; kvs <- kindGeneralize (mkTyConKind tc_binders tc_res_kind)
 
-    pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
+           ; let all_binders = mkNamedTyConBinders Inferred kvs ++ tc_binders
 
---------------
-mkTcTyConEnv :: TcTyCon -> TcTypeEnv
-mkTcTyConEnv tc = unitNameEnv (getName tc) (ATcTyCon tc)
+           ; (env, all_binders') <- zonkTyVarBinders all_binders
+           ; tc_res_kind'        <- zonkTcTypeToTypeX env tc_res_kind
+           ; scoped_tvs'         <- zonkTyVarTyVarPairs scoped_tvs
+
+             -- See Note [Check telescope again during generalisation]
+           ; let extra = text "NB: Implicitly declared variables come before others."
+           ; checkValidTelescope all_binders user_tyvars extra
+
+                      -- Make sure tc_kind' has the final, zonked kind variables
+           ; traceTc "Generalise kind" $
+             vcat [ ppr name, ppr tc_binders, ppr (mkTyConKind tc_binders tc_res_kind)
+                  , ppr kvs, ppr all_binders, ppr tc_res_kind
+                  , ppr all_binders', ppr tc_res_kind'
+                  , ppr scoped_tvs ]
 
-extendEnvWithTcTyCon :: TcTypeEnv -> TcTyCon -> TcTypeEnv
--- Makes a binding to put in the local envt, binding
--- a name to a TcTyCon
-extendEnvWithTcTyCon env tc
-  = extendNameEnv env (getName tc) (ATcTyCon tc)
+           ; return (mkTcTyCon name user_tyvars all_binders' tc_res_kind'
+                               scoped_tvs'
+                               (tyConFlavour tc)) }
+
+
+--------------
+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
+tcExtendKindEnvWithTyCons tcs
+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]
 
 --------------
 mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
 -- Maps each tycon/datacon to a suitable promotion error
 --    tc :-> APromotionErr TyConPE
 --    dc :-> APromotionErr RecDataConPE
---    See Note [ARecDataCon: Recursion and promoting data constructors]
+--    See Note [Recursion and promoting data constructors]
 
 mkPromotionErrorEnv decls
   = foldr (plusNameEnv . mk_prom_err_env . unLoc)
@@ -449,28 +607,18 @@ mk_prom_err_env decl
     -- Works for family declarations too
 
 --------------
-getInitialKinds :: [LTyClDecl GhcRn] -> TcM (NameEnv TcTyThing)
--- Maps each tycon to its initial kind,
--- and each datacon to a suitable promotion error
---    tc :-> ATcTyCon (tc:initial_kind)
---    dc :-> APromotionErr RecDataConPE
---    See Note [ARecDataCon: Recursion and promoting data constructors]
+getInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
+-- Returns a TcTyCon for each TyCon bound by the decls,
+-- each with its initial kind
 
-getInitialKinds decls
-  = tcExtendKindEnv promotion_err_env $
-    do { tc_kinds <- mapM (addLocM getInitialKind) decls
-       ; return (foldl plusNameEnv promotion_err_env tc_kinds) }
-  where
-    promotion_err_env = mkPromotionErrorEnv decls
+getInitialKinds decls = concatMapM (addLocM getInitialKind) decls
 
-getInitialKind :: TyClDecl GhcRn
-               -> TcM (NameEnv TcTyThing)
+getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
 -- Allocate a fresh kind variable for each TyCon and Class
--- For each tycon, return a NameEnv with
---      name :-> ATcTyCon (TcCyCon with kind k))
+-- For each tycon, return a TcTyCon with kind k
 -- where k is the kind of tc, derived from the LHS
---       of the definition (and probably including
---       kind unification variables)
+--         of the definition (and probably including
+--         kind unification variables)
 --      Example: data T a b = ...
 --      return (T, kv1 -> kv2 -> kv3)
 --
@@ -482,92 +630,94 @@ getInitialKind :: TyClDecl GhcRn
 
 getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
   = do { let cusk = hsDeclHasCusk decl
-       ; (tycon, inner_prs) <-
-           kcHsTyVarBndrs name ClassFlavour cusk True ktvs $
-           do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
-              ; return (constraintKind, inner_prs) }
-       ; return (extendEnvWithTcTyCon inner_prs tycon) }
+       ; tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $
+                  return constraintKind
+            -- See Note [Don't process associated types in kcLHsQTyVars]
+       ; inner_tcs <- tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $
+                      getFamDeclInitialKinds (Just cusk) ats
+       ; return (tycon : inner_tcs) }
 
 getInitialKind decl@(DataDecl { tcdLName = L _ name
                               , tcdTyVars = ktvs
                               , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
                                                          , dd_ND = new_or_data } })
-  = do  { (tycon, _) <-
-           kcHsTyVarBndrs name flav (hsDeclHasCusk decl) True ktvs $
-           do { res_k <- case m_sig of
-                           Just ksig -> tcLHsKindSig ksig
-                           Nothing   -> return liftedTypeKind
-              ; return (res_k, ()) }
-        ; return (mkTcTyConEnv tycon) }
-  where
-    flav = case new_or_data of
-             NewType  -> NewtypeFlavour
-             DataType -> DataTypeFlavour
+  = do  { tycon <-
+           kcLHsQTyVars name (newOrDataToFlavour new_or_data) (hsDeclHasCusk decl) ktvs $
+           case m_sig of
+             Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
+             Nothing   -> return liftedTypeKind
+        ; return [tycon] }
 
 getInitialKind (FamDecl { tcdFam = decl })
-  = getFamDeclInitialKind Nothing decl
+  = do { tc <- getFamDeclInitialKind Nothing decl
+       ; return [tc] }
 
 getInitialKind decl@(SynDecl { tcdLName = L _ name
                              , tcdTyVars = ktvs
                              , tcdRhs = rhs })
-  = do  { (tycon, _) <- kcHsTyVarBndrs name TypeSynonymFlavour
-                            (hsDeclHasCusk decl)
-                            True ktvs $
-            do  { res_k <- case kind_annotation rhs of
-                            Nothing -> newMetaKindVar
-                            Just ksig -> tcLHsKindSig ksig
-                ; return (res_k, ()) }
-        ; return (mkTcTyConEnv tycon) }
+  = do  { tycon <- kcLHsQTyVars name TypeSynonymFlavour (hsDeclHasCusk decl) ktvs $
+            case kind_annotation rhs of
+              Nothing -> newMetaKindVar
+              Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
+        ; return [tycon] }
   where
     -- Keep this synchronized with 'hsDeclHasCusk'.
     kind_annotation (L _ ty) = case ty of
-        HsParTy lty     -> kind_annotation lty
-        HsKindSig _ k   -> Just k
-        _               -> Nothing
+        HsParTy _ lty     -> kind_annotation lty
+        HsKindSig _ _ k   -> Just k
+        _                 -> Nothing
+
+getInitialKind (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "getInitialKind"
+getInitialKind (XTyClDecl _) = panic "getInitialKind"
 
 ---------------------------------
 getFamDeclInitialKinds :: Maybe Bool  -- if assoc., CUSKness of assoc. class
                        -> [LFamilyDecl GhcRn]
-                       -> TcM TcTypeEnv
+                       -> TcM [TcTyCon]
 getFamDeclInitialKinds mb_cusk decls
-  = do { tc_kinds <- mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
-       ; return (foldr plusNameEnv emptyNameEnv tc_kinds) }
+  = mapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
 
 getFamDeclInitialKind :: Maybe Bool  -- if assoc., CUSKness of assoc. class
                       -> FamilyDecl GhcRn
-                      -> TcM TcTypeEnv
+                      -> TcM TcTyCon
 getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName     = L _ name
                                                , fdTyVars    = ktvs
                                                , fdResultSig = L _ resultSig
                                                , fdInfo      = info })
-  = do { (tycon, _) <-
-           kcHsTyVarBndrs name flav cusk True ktvs $
-           do { res_k <- case resultSig of
-                      KindSig ki                        -> tcLHsKindSig ki
-                      TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki
-                      _ -- open type families have * return kind by default
-                        | tcFlavourIsOpen flav     -> return liftedTypeKind
-                        -- closed type families have their return kind inferred
-                        -- by default
-                        | otherwise                -> newMetaKindVar
-              ; return (res_k, ()) }
-       ; return (mkTcTyConEnv tycon) }
+  = do { tycon <- kcLHsQTyVars name flav cusk ktvs $
+           case resultSig of
+             KindSig _ ki                          -> tcLHsKindSig ctxt ki
+             TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
+             _ -- open type families have * return kind by default
+               | tcFlavourIsOpen flav     -> return liftedTypeKind
+               -- closed type families have their return kind inferred
+               -- by default
+               | otherwise                -> newMetaKindVar
+       ; return tycon }
   where
     cusk  = famDeclHasCusk mb_cusk decl
     flav  = case info of
-      DataFamily         -> DataFamilyFlavour
-      OpenTypeFamily     -> OpenTypeFamilyFlavour
+      DataFamily         -> DataFamilyFlavour (isJust mb_cusk)
+      OpenTypeFamily     -> OpenTypeFamilyFlavour (isJust mb_cusk)
       ClosedTypeFamily _ -> ClosedTypeFamilyFlavour
+    ctxt  = TyFamResKindCtxt name
+getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
 
 ------------------------------------------------------------------------
 kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
   -- See Note [Kind checking for type and class decls]
 kcLTyClDecl (L loc decl)
+  | hsDeclHasCusk decl  -- See Note [Skip decls with CUSKs in kcLTyClDecl]
+  = traceTc "kcTyClDecl skipped due to cusk" (ppr tc_name)
+
+  | otherwise
   = setSrcSpan loc $
     tcAddDeclCtxt decl $
-    do { traceTc "kcTyClDecl {" (ppr (tyClDeclLName decl))
+    do { traceTc "kcTyClDecl {" (ppr tc_name)
        ; kcTyClDecl decl
-       ; traceTc "kcTyClDecl done }" (ppr (tyClDeclLName decl)) }
+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }
+  where
+    tc_name = tyClDeclLName decl
 
 kcTyClDecl :: TyClDecl GhcRn -> TcM ()
 -- This function is used solely for its side effect on kind variables
@@ -576,10 +726,10 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM ()
 --    by getInitialKind, so we can ignore them here.
 
 kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })
-  | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn
+  | HsDataDefn { dd_cons = cons@(L _ (ConDeclGADT {}) : _), dd_ctxt = L _ [] } <- defn
   = mapM_ (wrapLocM kcConDecl) cons
     -- hs_tvs and dd_kindSig already dealt with in getInitialKind
-    -- If dd_kindSig is Just, this must be a GADT-style decl,
+    -- This must be a GADT-style decl,
     --        (see invariants of DataDefn declaration)
     -- so (a) we don't need to bring the hs_tvs into scope, because the
     --        ConDecls bind all their own variables
@@ -603,50 +753,57 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kc_sig)     sigs }
   where
-    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
-    kc_sig _                        = return ()
+    kc_sig (ClassOpSig _ _ nms op_ty)
+             = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty
+    kc_sig _ = return ()
 
-kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name
-                                , fdInfo   = fd_info }))
+kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = L _ fam_tc_name
+                                  , fdInfo   = fd_info }))
 -- closed type families look at their equations, but other families don't
 -- do anything here
   = case fd_info of
       ClosedTypeFamily (Just eqns) ->
         do { fam_tc <- kcLookupTcTyCon fam_tc_name
-           ; mapM_ (kcTyFamInstEqn (famTyConShape fam_tc)) eqns }
+           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }
       _ -> return ()
+kcTyClDecl (FamDecl _ (XFamilyDecl _))              = panic "kcTyClDecl"
+kcTyClDecl (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "kcTyClDecl"
+kcTyClDecl (XTyClDecl _)                            = panic "kcTyClDecl"
 
 -------------------
 kcConDecl :: ConDecl GhcRn -> TcM ()
-kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
-                      , con_cxt = ex_ctxt, con_details = details })
+kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                      , con_mb_cxt = ex_ctxt, con_args = args })
   = addErrCtxt (dataConCtxtName [name]) $
-         -- the 'False' says that the existentials don't have a CUSK, as the
-         -- concept doesn't really apply here. We just need to bring the variables
-         -- into scope. (Similarly, the choice of PromotedDataConFlavour isn't
-         -- particularly important.)
-    do { _ <- kcHsTyVarBndrs (unLoc name) PromotedDataConFlavour
-                             False False
-                             ((fromMaybe emptyLHsQTvs ex_tvs)) $
-              do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
-                 ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
-                 ; return (panic "kcConDecl", ()) }
+      -- See Note [Use TyVarTvs in kind-checking pass]
+    kcExplicitTKBndrs ex_tvs $
+    do { _ <- tcHsMbContext ex_ctxt
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) }
               -- We don't need to check the telescope here, because that's
               -- done in tcConDecl
-       ; return () }
 
 kcConDecl (ConDeclGADT { con_names = names
-                       , con_type = ty })
-  = addErrCtxt (dataConCtxtName names) $
-      do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty
-                -- Even though the data constructor's type is closed, we
-                -- must still call tcGadtSigType, because that influences
-                -- the inferred kind of the /type/ constructor.  Example:
-                --    data T f a where
-                --      MkT :: f a -> T f a
-                -- If we don't look at MkT we won't get the correct kind
-                -- for the type constructor T
-         ; return () }
+                       , con_qvars = qtvs, con_mb_cxt = cxt
+                       , con_args = args, con_res_ty = res_ty })
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = -- Even though the data constructor's type is closed, we
+    -- must still kind-check the type, because that may influence
+    -- the inferred kind of the /type/ constructor.  Example:
+    --    data T f a where
+    --      MkT :: f a -> T f a
+    -- If we don't look at MkT we won't get the correct kind
+    -- for the type constructor T
+    addErrCtxt (dataConCtxtName names) $
+    discardResult $
+    kcImplicitTKBndrs implicit_tkv_nms $
+    kcExplicitTKBndrs explicit_tkv_nms $
+    do { _ <- tcHsMbContext cxt
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+       ; _ <- tcHsOpenType res_ty
+       ; return () }
+kcConDecl (XConDecl _) = panic "kcConDecl"
+kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"
 
 {-
 Note [Recursion and promoting data constructors]
@@ -665,6 +822,54 @@ mappings:
 APromotionErr is only used for DataCons, and only used during type checking
 in tcTyClGroup.
 
+Note [Use TyVarTvs in kind-checking pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Proxy a where
+    MkProxy1 :: forall k (b :: k). Proxy b
+    MkProxy2 :: forall j (c :: j). Proxy c
+
+It seems reasonable that this should be accepted. But something very strange
+is going on here: when we're kind-checking this declaration, we need to unify
+the kind of `a` with k and j -- even though k and j's scopes are local to the type of
+MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during
+the kind-checking pass. First off, note that it's OK if the kind-checking pass
+is too permissive: we'll snag the problems in the type-checking pass later.
+(This extra permissiveness might happen with something like
+
+  data SameKind :: k -> k -> Type
+  data Bad a where
+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)
+
+which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected
+in the second pass, though. Test case: polykinds/TyVarTvKinds3)
+Recall that the kind-checking pass exists solely to collect constraints
+on the kinds and to power unification.
+
+To achieve the use of TyVarTvs, we must be careful to use specialized functions
+that produce TyVarTvs, not ordinary skolems. This is why we need
+kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their
+tc... variants.
+
+The drawback of this approach is sometimes it will accept a definition that
+a (hypothetical) declarative specification would likely reject. As a general
+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,
+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs
+approach allows a limited form of polymorphic recursion *without* a CUSK.
+
+To wit:
+  data T a = forall k (b :: k). MkT (T b) Int
+  (test case: dependent/should_compile/T14066a)
+
+Note that this is polymorphically recursive, with the recursive occurrence
+of T used at a kind other than a's kind. The approach outlined here accepts
+this definition, because this kind is still a kind variable (and so the
+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a
+way to describe exactly what declarations will be accepted and which will
+be rejected (without a CUSK). However, the accepted definitions are indeed
+well-kinded and any rejected definitions would be accepted with a CUSK,
+and so this wrinkle need not cause anyone to lose sleep.
 
 ************************************************************************
 *                                                                      *
@@ -705,12 +910,11 @@ without looking at T?  Delicate answer: during tcTyClDecl, we extend
 
 Then:
 
-  * During TcHsType.kcTyVar we look in the *local* env, to get the
-    known kind for T.
+  * During TcHsType.tcTyVar we look in the *local* env, to get the
+    fully-known, not knot-tied TcTyCon for T.
 
-  * But in TcHsType.ds_type (and ds_var_app in particular) we look in
-    the *global* env to get the TyCon. But we must be careful not to
-    force the TyCon or we'll get a loop.
+  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)
+    we look in the *global* env to get the TyCon.
 
 This fancy footwork (with two bindings for T) is only necessary for the
 TyCons or Classes of this recursive group.  Earlier, finished groups,
@@ -725,19 +929,19 @@ is done by establishing an "initial kind", which is a rather uninformed
 guess at a tycon's kind (by counting arguments, mainly) and then
 using this initial kind for recursive occurrences.
 
-The initial kind is stored in exactly the same way during kind-checking
-as it is during type-checking (Note [Type checking recursive type and class
-declarations]): in the *local* environment, with ATcTyCon. But we still
-must store *something* in the *global* environment. Even though we
-discard the result of kind-checking, we sometimes need to produce error
-messages. These error messages will want to refer to the tycons being
-checked, except that they don't exist yet, and it would be Terribly
-Annoying to get the error messages to refer back to HsSyn. So we
-create a TcTyCon and put it in the global env. This tycon can
-print out its name and knows its kind,
-but any other action taken on it will panic. Note
-that TcTyCons are *not* knot-tied, unlike the rather valid but
-knot-tied ones that occur during type-checking.
+The initial kind is stored in exactly the same way during
+kind-checking as it is during type-checking (Note [Type checking
+recursive type and class declarations]): in the *local* environment,
+with ATcTyCon. But we still must store *something* in the *global*
+environment. Even though we discard the result of kind-checking, we
+sometimes need to produce error messages. These error messages will
+want to refer to the tycons being checked, except that they don't
+exist yet, and it would be Terribly Annoying to get the error messages
+to refer back to HsSyn. So we create a TcTyCon and put it in the
+global env. This tycon can print out its name and knows its kind, but
+any other action taken on it will panic. Note that TcTyCons are *not*
+knot-tied, unlike the rather valid but knot-tied ones that occur
+during type-checking.
 
 Note [Declarations for wired-in things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -756,8 +960,10 @@ tcTyClDecl roles_info (L loc decl)
 
   | otherwise
   = setSrcSpan loc $ tcAddDeclCtxt decl $
-    do { traceTc "tcTyAndCl-x" (ppr decl)
-       ; tcTyClDecl1 Nothing roles_info decl }
+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
+       ; tc <- tcTyClDecl1 Nothing roles_info decl
+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
+       ; return tc }
 
   -- "type family" declarations
 tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon
@@ -773,63 +979,252 @@ tcTyClDecl1 _parent roles_info
 
   -- "data/newtype" declaration
 tcTyClDecl1 _parent roles_info
-            (DataDecl { tcdLName = L _ tc_name, tcdDataDefn = defn })
+            (DataDecl { tcdLName = L _ tc_name
+                      , tcdDataDefn = defn })
   = ASSERT( isNothing _parent )
     tcTyClTyVars tc_name $ \ tycon_binders res_kind ->
     tcDataDefn roles_info tc_name tycon_binders res_kind defn
 
 tcTyClDecl1 _parent roles_info
             (ClassDecl { tcdLName = L _ class_name
-            , tcdCtxt = ctxt, tcdMeths = meths
+            , tcdCtxt = hs_ctxt, tcdMeths = meths
             , tcdFDs = fundeps, tcdSigs = sigs
             , tcdATs = ats, tcdATDefs = at_defs })
   = ASSERT( isNothing _parent )
-    do { clas <- fixM $ \ clas ->
-            -- We need the knot because 'clas' is passed into tcClassATs
-            tcTyClTyVars class_name $ \ binders res_kind ->
-            do { MASSERT( isConstraintKind res_kind )
-               ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
-               ; let tycon_name = class_name        -- We use the same name
-                     roles = roles_info tycon_name  -- for TyCon and Class
-
-               ; ctxt' <- solveEqualities $ tcHsContext ctxt
-               ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'
-                       -- Squeeze out any kind unification variables
-               ; fds'  <- mapM (addLocM tc_fundep) fundeps
-               ; sig_stuff <- tcClassSigs class_name sigs meths
-               ; at_stuff <- tcClassATs class_name clas ats at_defs
-               ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
-               -- TODO: Allow us to distinguish between abstract class,
-               -- and concrete class with no methods (maybe by
-               -- specifying a trailing where or not
-               ; is_boot <- tcIsHsBootOrSig
-               ; let body | is_boot, null ctxt', null at_stuff, null sig_stuff
-                          = Nothing
-                          | otherwise
-                          = Just (ctxt', at_stuff, sig_stuff, mindef)
-               ; clas <- buildClass class_name binders roles fds' body
-               ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
-                                        ppr fds')
-               ; return clas }
-
-         ; return (classTyCon clas) }
+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt
+                              meths fundeps sigs ats at_defs
+       ; return (classTyCon clas) }
+
+tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"
+
+
+{- *********************************************************************
+*                                                                      *
+          Class declarations
+*                                                                      *
+********************************************************************* -}
+
+tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn
+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltEqn GhcRn]
+             -> TcM Class
+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
+  = fixM $ \ clas ->
+    -- We need the knot because 'clas' is passed into tcClassATs
+    tcTyClTyVars class_name $ \ binders res_kind ->
+    do { MASSERT2( tcIsConstraintKind res_kind
+                 , ppr class_name $$ ppr res_kind )
+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
+       ; let tycon_name = class_name        -- We use the same name
+             roles = roles_info tycon_name  -- for TyCon and Class
+
+       ; (ctxt, fds, sig_stuff, at_stuff)
+            <- solveEqualities $
+               do { ctxt <- tcHsContext hs_ctxt
+                  ; fds  <- mapM (addLocM tc_fundep) fundeps
+                  ; sig_stuff <- tcClassSigs class_name sigs meths
+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs
+                  ; return (ctxt, fds, sig_stuff, at_stuff) }
+
+       -- The solveEqualities will report errors for any
+       -- unsolved equalities, so these zonks should not encounter
+       -- any unfilled coercion variables unless there is such an error
+       -- The zonk also squeeze out the TcTyCons, and converts
+       -- Skolems to tyvars.
+       ; ze        <- emptyZonkEnv
+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt
+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff
+         -- ToDo: do we need to zonk at_stuff?
+
+       -- TODO: Allow us to distinguish between abstract class,
+       -- and concrete class with no methods (maybe by
+       -- specifying a trailing where or not
+
+       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
+       ; is_boot <- tcIsHsBootOrSig
+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff
+                  = Nothing
+                  | otherwise
+                  = Just (ctxt, at_stuff, sig_stuff, mindef)
+
+       ; clas <- buildClass class_name binders roles fds body
+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
+                                ppr fds)
+       ; return clas }
   where
     tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
                                 ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
                                 ; return (tvs1', tvs2') }
 
+
+{- Note [Associated type defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The following is an example of associated type defaults:
+             class C a where
+               data D a
+
+               type F a b :: *
+               type F a b = [a]        -- Default
+
+Note that we can get default definitions only for type families, not data
+families.
+-}
+
+tcClassATs :: Name                   -- The class name (not knot-tied)
+           -> Class                  -- The class parent of this associated type
+           -> [LFamilyDecl GhcRn]    -- Associated types.
+           -> [LTyFamDefltEqn GhcRn] -- Associated type defaults.
+           -> TcM [ClassATItem]
+tcClassATs class_name cls ats at_defs
+  = do {  -- Complain about associated type defaults for non associated-types
+         sequence_ [ failWithTc (badATErr class_name n)
+                   | n <- map at_def_tycon at_defs
+                   , not (n `elemNameSet` at_names) ]
+       ; mapM tc_at ats }
+  where
+    at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
+    at_def_tycon (L _ eqn) = unLoc (feqn_tycon eqn)
+
+    at_fam_name :: LFamilyDecl GhcRn -> Name
+    at_fam_name (L _ decl) = unLoc (fdLName decl)
+
+    at_names = mkNameSet (map at_fam_name ats)
+
+    at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]
+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
+                                          (at_def_tycon at_def) [at_def])
+                        emptyNameEnv at_defs
+
+    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at
+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
+                                  `orElse` []
+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs
+                  ; return (ATI fam_tc atd) }
+
+-------------------------
+tcDefaultAssocDecl :: TyCon                    -- ^ Family TyCon (not knot-tied)
+                   -> [LTyFamDefltEqn GhcRn]        -- ^ Defaults
+                   -> TcM (Maybe (KnotTied Type, SrcSpan))   -- ^ Type checked RHS
+tcDefaultAssocDecl _ []
+  = return Nothing  -- No default declaration
+
+tcDefaultAssocDecl _ (d1:_:_)
+  = failWithTc (text "More than one default declaration for"
+                <+> ppr (feqn_tycon (unLoc d1)))
+
+tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name
+                                         , feqn_pats = hs_tvs
+                                         , feqn_rhs = rhs })]
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars}
+           , hsq_explicit = exp_vars } <- hs_tvs
+  = -- See Note [Type-checking default assoc decls]
+    setSrcSpan loc $
+    tcAddFamInstCtxt (text "default type instance") tc_name $
+    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
+       ; let fam_tc_name = tyConName fam_tc
+             fam_arity = length (tyConVisibleTyVars fam_tc)
+
+       -- Kind of family check
+       ; ASSERT( fam_tc_name == tc_name )
+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+
+       -- Arity check
+       ; checkTc (exp_vars `lengthIs` fam_arity)
+                 (wrongNumberOfParmsErr fam_arity)
+
+       -- Typecheck RHS
+       ; let all_vars = imp_vars ++ map hsLTyVarName exp_vars
+             pats     = map hsLTyVarBndrToType exp_vars
+
+          -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get
+          -- the LHsQTyVars used for declaring a tycon, but the names here
+          -- are different.
+
+          -- You might think we should pass in some ClsInstInfo, as we're looking
+          -- at an associated type. But this would be wrong, because an associated
+          -- type default LHS can mention *different* type variables than the
+          -- enclosing class. So it's treated more as a freestanding beast.
+       ; (pats', rhs_ty)
+           <- tcFamTyPats fam_tc Nothing all_vars pats
+              (kcTyFamEqnRhs Nothing rhs) $
+              \tvs pats rhs_kind ->
+              do { rhs_ty <- solveEqualities $
+                             tcCheckLHsType rhs rhs_kind
+
+                     -- Zonk the patterns etc into the Type world
+                 ; (ze, _) <- zonkTyBndrs tvs
+                 ; pats'   <- zonkTcTypesToTypesX ze pats
+                 ; rhs_ty'  <- zonkTcTypeToTypeX ze rhs_ty
+                 ; return (pats', rhs_ty') }
+
+         -- See Note [Type-checking default assoc decls]
+       ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of
+           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )
+           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)
+           -- We check for well-formedness and validity later,
+           -- in checkValidClass
+     }
+tcDefaultAssocDecl _ [L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"
+tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) (XLHsQTyVars _) _ _)]
+  = panic "tcDefaultAssocDecl"
+
+{- Note [Type-checking default assoc decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this default declaration for an associated type
+
+   class C a where
+      type F (a :: k) b :: *
+      type F x y = Proxy x -> y
+
+Note that the class variable 'a' doesn't scope over the default assoc
+decl (rather oddly I think), and (less oddly) neither does the second
+argument 'b' of the associated type 'F', or the kind variable 'k'.
+Instead, the default decl is treated more like a top-level type
+instance.
+
+However we store the default rhs (Proxy x -> y) in F's TyCon, using
+F's own type variables, so we need to convert it to (Proxy a -> b).
+We do this by calling tcMatchTys to match them up.  This also ensures
+that x's kind matches a's and similarly for y and b.  The error
+message isn't great, mind you.  (Trac #11361 was caused by not doing a
+proper tcMatchTys here.)
+
+Recall also that the left-hand side of an associated type family
+default is always just variables -- no tycons here. Accordingly,
+the patterns used in the tcMatchTys won't actually be knot-tied,
+even though we're in the knot. This is too delicate for my taste,
+but it works.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+          Type family declarations
+*                                                                      *
+********************************************************************* -}
+
 tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
 tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name)
-                              , fdTyVars = tvs, fdResultSig = L _ sig
+                              , fdResultSig = L _ sig, fdTyVars = user_tyvars
                               , fdInjectivityAnn = inj })
   | DataFamily <- fam_info
   = tcTyClTyVars tc_name $ \ binders res_kind -> do
   { traceTc "data family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; (extra_binders, real_res_kind) <- tcDataKindSig res_kind
+
+  -- Check the kind signature, if any.
+  -- Data families might have a variable return kind.
+  -- See See Note [Arity of data families] in FamInstEnv.
+  ; (extra_binders, final_res_kind) <- tcDataKindSig binders res_kind
+  ; checkTc (tcIsLiftedTypeKind final_res_kind
+             || isJust (tcGetCastedTyVar_maybe final_res_kind))
+            (badKindSig False res_kind)
+
   ; tc_rep_name <- newTyConRepName tc_name
   ; let tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders)
-                              real_res_kind
+                              final_res_kind
                               (resultVariableName sig)
                               (DataFamilyTyCon tc_rep_name)
                               parent NotInjective
@@ -870,22 +1265,17 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
            Just eqns -> do {
 
          -- Process the equations, creating CoAxBranches
-       ; let fam_tc_shape = (tc_name, length $ hsQTvExplicit tvs, binders, res_kind)
+       ; let tc_fam_tc = mkTcTyCon tc_name (ppr user_tyvars) binders res_kind
+                                   [] ClosedTypeFamilyFlavour
 
-       ; branches <- mapM (tcTyFamInstEqn fam_tc_shape Nothing) eqns
+       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc Nothing) eqns
          -- Do not attempt to drop equations dominated by earlier
          -- ones here; in the case of mutual recursion with a data
          -- type, we get a knot-tying failure.  Instead we check
          -- for this afterwards, in TcValidity.checkValidCoAxiom
          -- Example: tc265
 
-         -- Create a CoAxiom, with the correct src location. It is Vitally
-         -- Important that we do not pass the branches into
-         -- newFamInstAxiomName. They have types that have been zonked inside
-         -- the knot and we will die if we look at them. This is OK here
-         -- because there will only be one axiom, so we don't need to
-         -- differentiate names.
-         -- See [Zonking inside the knot] in TcHsType
+         -- Create a CoAxiom, with the correct src location.
        ; co_ax_name <- newFamInstAxiomName tc_lname []
 
        ; let mb_co_ax
@@ -901,7 +1291,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na
        ; return fam_tc } }
 
   | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker
-
+tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"
 
 -- | Maybe return a list of Bools that say whether a type family was declared
 -- injective in the corresponding type arguments. Length of the list is equal to
@@ -956,7 +1346,7 @@ tcTySynRhs roles_info tc_name binders res_kind hs_ty
   = do { env <- getLclEnv
        ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
        ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
-       ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
+       ; rhs_ty <- zonkTcTypeToType rhs_ty
        ; let roles = roles_info tc_name
              tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty
        ; return tycon }
@@ -970,16 +1360,18 @@ tcDataDefn roles_info
          (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
                      , dd_cons = cons })
- =  do { (extra_bndrs, real_res_kind) <- tcDataKindSig res_kind
+ =  do { tcg_env         <- getGblEnv
+       ; let hsc_src = tcg_src tcg_env
+       ; (extra_bndrs, final_res_kind) <- tcDataKindSig tycon_binders res_kind
+       ; unless (mk_permissive_kind hsc_src cons) $
+         checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+
        ; let final_bndrs  = tycon_binders `chkAppend` extra_bndrs
              roles        = roles_info tc_name
 
        ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt
-       ; stupid_theta    <- zonkTcTypeToTypes emptyZonkEnv
-                                              stupid_tc_theta
+       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta
        ; kind_signatures <- xoptM LangExt.KindSignatures
-       ; tcg_env         <- getGblEnv
-       ; let hsc_src = tcg_src tcg_env
 
              -- Check that we don't use kind signatures without Glasgow extensions
        ; when (isJust mb_ksig) $
@@ -994,7 +1386,7 @@ tcDataDefn roles_info
              ; tc_rep_nm <- newTyConRepName tc_name
              ; return (mkAlgTyCon tc_name
                                   final_bndrs
-                                  real_res_kind
+                                  final_res_kind
                                   roles
                                   (fmap unLoc cType)
                                   stupid_theta tc_rhs
@@ -1003,8 +1395,14 @@ tcDataDefn roles_info
        ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)
        ; return tycon }
   where
+    -- Abstract data types in hsig files can have arbitrary kinds,
+    -- because they may be implemented by type synonyms
+    -- (which themselves can have arbitrary kinds, not just *)
+    mk_permissive_kind HsigFile [] = True
+    mk_permissive_kind _ _ = False
+
     -- In hs-boot, a 'data' declaration with no constructors
-    -- indicates an nominally distinct abstract data type.
+    -- indicates a nominally distinct abstract data type.
     mk_tc_rhs HsBootFile _ []
       = return AbstractTyCon
 
@@ -1016,194 +1414,156 @@ tcDataDefn roles_info
           DataType -> return (mkDataTyConRhs data_cons)
           NewType  -> ASSERT( not (null data_cons) )
                       mkNewTyConRhs tc_name tycon (head data_cons)
+tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"
 
-{-
-************************************************************************
-*                                                                      *
-               Typechecking associated types (in class decls)
-               (including the associated-type defaults)
-*                                                                      *
-************************************************************************
-
-Note [Associated type defaults]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following is an example of associated type defaults:
-             class C a where
-               data D a
-
-               type F a b :: *
-               type F a b = [a]        -- Default
-
-Note that we can get default definitions only for type families, not data
-families.
--}
-
-tcClassATs :: Name                   -- The class name (not knot-tied)
-           -> Class                  -- The class parent of this associated type
-           -> [LFamilyDecl GhcRn]    -- Associated types.
-           -> [LTyFamDefltEqn GhcRn] -- Associated type defaults.
-           -> TcM [ClassATItem]
-tcClassATs class_name cls ats at_defs
-  = do {  -- Complain about associated type defaults for non associated-types
-         sequence_ [ failWithTc (badATErr class_name n)
-                   | n <- map at_def_tycon at_defs
-                   , not (n `elemNameSet` at_names) ]
-       ; mapM tc_at ats }
-  where
-    at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
-    at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn)
-
-    at_fam_name :: LFamilyDecl GhcRn -> Name
-    at_fam_name (L _ decl) = unLoc (fdLName decl)
-
-    at_names = mkNameSet (map at_fam_name ats)
-
-    at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]
-    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
-    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
-                                          (at_def_tycon at_def) [at_def])
-                        emptyNameEnv at_defs
-
-    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at
-                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
-                                  `orElse` []
-                  ; atd <- tcDefaultAssocDecl fam_tc at_defs
-                  ; return (ATI fam_tc atd) }
 
 -------------------------
-tcDefaultAssocDecl :: TyCon                    -- ^ Family TyCon (not knot-tied)
-                   -> [LTyFamDefltEqn GhcRn]        -- ^ Defaults
-                   -> TcM (Maybe (Type, SrcSpan))   -- ^ Type checked RHS
-tcDefaultAssocDecl _ []
-  = return Nothing  -- No default declaration
-
-tcDefaultAssocDecl _ (d1:_:_)
-  = failWithTc (text "More than one default declaration for"
-                <+> ppr (tfe_tycon (unLoc d1)))
-
-tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
-                                           , tfe_pats = hs_tvs
-                                           , tfe_rhs = rhs })]
-  | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs
-  = -- See Note [Type-checking default assoc decls]
-    setSrcSpan loc $
-    tcAddFamInstCtxt (text "default type instance") tc_name $
-    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
-       ; let shape@(fam_tc_name, fam_arity, _, _) = famTyConShape fam_tc
-
-       -- Kind of family check
-       ; ASSERT( fam_tc_name == tc_name )
-         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
-
-       -- Arity check
-       ; checkTc (exp_vars `lengthIs` fam_arity)
-                 (wrongNumberOfParmsErr fam_arity)
-
-       -- Typecheck RHS
-       ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
-                         , hsib_body = map hsLTyVarBndrToType exp_vars
-                         , hsib_closed = False } -- this field is ignored, anyway
-          -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get
-          -- the LHsQTyVars used for declaring a tycon, but the names here
-          -- are different.
-       ; (pats', rhs_ty)
-           <- tcFamTyPats shape Nothing pats
-              (discardResult . tcCheckLHsType rhs) $ \tvs pats rhs_kind ->
-              do { rhs_ty <- solveEqualities $
-                             tcCheckLHsType rhs rhs_kind
-
-                     -- Zonk the patterns etc into the Type world
-                 ; (ze, _) <- zonkTyBndrsX emptyZonkEnv tvs
-                 ; pats'   <- zonkTcTypeToTypes ze pats
-                 ; rhs_ty'  <- zonkTcTypeToType ze rhs_ty
-                 ; return (pats', rhs_ty') }
-
-         -- See Note [Type-checking default assoc decls]
-       ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of
-           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )
-           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)
-           -- We check for well-formedness and validity later,
-           -- in checkValidClass
-     }
-
-{- Note [Type-checking default assoc decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this default declaration for an associated type
-
-   class C a where
-      type F (a :: k) b :: *
-      type F x y = Proxy x -> y
-
-Note that the class variable 'a' doesn't scope over the default assoc
-decl (rather oddly I think), and (less oddly) neither does the second
-argument 'b' of the associated type 'F', or the kind variable 'k'.
-Instead, the default decl is treated more like a top-level type
-instance.
-
-However we store the default rhs (Proxy x -> y) in F's TyCon, using
-F's own type variables, so we need to convert it to (Proxy a -> b).
-We do this by calling tcMatchTys to match them up.  This also ensures
-that x's kind matches a's and similarly for y and b.  The error
-message isn't great, mind you.  (Trac #11361 was caused by not doing a
-proper tcMatchTys here.)  -}
-
--------------------------
-kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn GhcRn -> TcM ()
-kcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_)
-    (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
-                     , tfe_pats  = pats
-                     , tfe_rhs   = hs_ty }))
+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
+kcTyFamInstEqn tc_fam_tc
+    (L loc (HsIB { hsib_ext = tv_names
+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_pats   = pats
+                                      , feqn_rhs    = hs_ty }}))
   = setSrcSpan loc $
-    do { checkTc (fam_tc_name == eqn_tc_name)
-                 (wrongTyFamName fam_tc_name eqn_tc_name)
-       ; discardResult $
-         tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
-                        pats (discardResult . (tcCheckLHsType hs_ty)) }
-
-tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
-               -> TcM CoAxBranch
+    do { traceTc "kcTyFamInstEqn" (vcat
+           [ text "tc_name =" <+> ppr eqn_tc_name
+           , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
+           , text "hsib_vars =" <+> ppr tv_names
+           , text "feqn_pats =" <+> ppr pats ])
+       ; checkTc (fam_name == eqn_tc_name)
+                 (wrongTyFamName fam_name eqn_tc_name)
+          -- this check reports an arity error instead of a kind error; easier for user
+       ; checkTc (pats `lengthIs` vis_arity) $
+                  wrongNumberOfParmsErr vis_arity
+       ; kcFamTyPats tc_fam_tc tv_names pats $ \ rhs_kind ->
+         discardResult $ kcTyFamEqnRhs Nothing hs_ty rhs_kind }
+  where
+    fam_name = tyConName tc_fam_tc
+    vis_arity = length (tyConVisibleTyVars tc_fam_tc)
+kcTyFamInstEqn _ (L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"
+kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"
+
+-- Infer the kind of the type on the RHS of a type family eqn. Then use
+-- this kind to check the kind of the LHS of the equation. This is useful
+-- as the callback to tcFamTyPats.
+kcTyFamEqnRhs :: Maybe ClsInstInfo
+              -> LHsType GhcRn        -- ^ Eqn RHS
+              -> TcKind               -- ^ Inferred kind of left-hand side
+              -> TcM ([TcType], TcKind)  -- ^ New pats, inst'ed kind of left-hand side
+kcTyFamEqnRhs mb_clsinfo rhs_hs_ty lhs_ki
+  = do { -- It's still possible the lhs_ki has some foralls. Instantiate these away.
+         (new_pats, insted_lhs_ki)
+           <- instantiateTyUntilN mb_kind_env 0 lhs_ki
+
+       ; traceTc "kcTyFamEqnRhs" (vcat
+           [ text "rhs_hs_ty =" <+> ppr rhs_hs_ty
+           , text "lhs_ki =" <+> ppr lhs_ki
+           , text "insted_lhs_ki =" <+> ppr insted_lhs_ki
+           , text "new_pats =" <+> ppr new_pats
+           ])
+
+       ; _ <- tcCheckLHsType rhs_hs_ty insted_lhs_ki
+
+       ; return (new_pats, insted_lhs_ki) }
+  where
+    mb_kind_env = thdOf3 <$> mb_clsinfo
+
+tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
+               -> TcM (KnotTied CoAxBranch)
 -- Needs to be here, not in TcInstDcls, because closed families
 -- (typechecked here) have TyFamInstEqns
-tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo
-    (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name
-                     , tfe_pats  = pats
-                     , tfe_rhs   = hs_ty }))
-  = ASSERT( fam_tc_name == eqn_tc_name )
+tcTyFamInstEqn fam_tc mb_clsinfo
+    (L loc (HsIB { hsib_ext = tv_names
+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_pats   = pats
+                                      , feqn_rhs    = hs_ty }}))
+  = ASSERT( getName fam_tc == eqn_tc_name )
     setSrcSpan loc $
-    tcFamTyPats fam_tc_shape mb_clsinfo pats
-                (discardResult . (tcCheckLHsType hs_ty)) $
+    tcFamTyPats fam_tc mb_clsinfo tv_names pats
+                (kcTyFamEqnRhs mb_clsinfo hs_ty) $
                     \tvs pats res_kind ->
-    do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
-
-       ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs
-       ; pats'      <- zonkTcTypeToTypes ze pats
-       ; rhs_ty'    <- zonkTcTypeToType ze rhs_ty
-       ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTyVars tvs')
-          -- don't print out the pats here, as they might be zonked inside the knot
+    do { traceTc "tcTyFamInstEqn {" (ppr eqn_tc_name <+> ppr pats)
+       ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
+       ; traceTc "tcTyFamInstEqn 1" (ppr eqn_tc_name <+> ppr pats)
+       ; (ze, tvs') <- zonkTyBndrs tvs
+       ; traceTc "tcTyFamInstEqn 2" (ppr eqn_tc_name <+> ppr pats)
+       ; pats'      <- zonkTcTypesToTypesX ze pats
+       ; traceTc "tcTyFamInstEqn 3" (ppr eqn_tc_name <+> ppr pats $$ ppr rhs_ty)
+       ; rhs_ty'    <- zonkTcTypeToTypeX ze rhs_ty
+       ; traceTc "tcTyFamInstEqn 4" (ppr fam_tc <+> pprTyVars tvs')
        ; return (mkCoAxBranch tvs' [] pats' rhs_ty'
                               (map (const Nominal) tvs')
                               loc) }
-
-kcDataDefn :: Name                -- ^ the family name, for error msgs only
-           -> HsTyPats GhcRn      -- ^ the patterns, for error msgs only
-           -> HsDataDefn GhcRn    -- ^ the RHS
-           -> TcKind              -- ^ the expected kind
-           -> TcM ()
+tcTyFamInstEqn _ _ (L _ (XHsImplicitBndrs _)) = panic "tcTyFamInstEqn"
+tcTyFamInstEqn _ _ (L _ (HsIB _ (XFamEqn _))) = panic "tcTyFamInstEqn"
+
+kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
+                                  -- (associated types only)
+           -> DataFamInstDecl GhcRn
+           -> TcKind              -- ^ the kind of the tycon applied to pats
+           -> TcM ([TcType], TcKind)
+             -- ^ the kind signature might force instantiation
+             -- of the tycon; this returns any extra args and the inst'ed kind
+             -- See Note [Instantiating a family tycon]
 -- Used for 'data instance' only
 -- Ordinary 'data' is handled by kcTyClDec
-kcDataDefn fam_name (HsIB { hsib_body = pats })
-           (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k
+kcDataDefn mb_kind_env
+           (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+              FamEqn { feqn_tycon  = fam_name
+                     , feqn_pats   = pats
+                     , feqn_fixity = fixity
+                     , feqn_rhs    = HsDataDefn { dd_ctxt = ctxt
+                                                , dd_cons = cons
+                                                , dd_kindSig = mb_kind } }}})
+           res_k
   = do  { _ <- tcHsContext ctxt
         ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
           -- See Note [Failing early in kcDataDefn]
-        ; discardResult $
-          case mb_kind of
-            Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind
-            Just k  -> do { k' <- tcLHsKindSig k
-                          ; unifyKind (Just hs_ty_pats) res_k k' } }
+        ; exp_res_kind <- case mb_kind of
+            Nothing -> return liftedTypeKind
+            Just k  -> tcLHsKindSig (DataKindCtxt (unLoc fam_name)) k
+
+          -- The expected type might have a forall at the type. Normally, we
+          -- can't skolemise in kinds because we don't have type-level lambda.
+          -- But here, we're at the top-level of an instance declaration, so
+          -- we actually have a place to put the regeneralised variables.
+          -- Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
+          -- Examples in indexed-types/should_compile/T12369
+        ; let (tvs_to_skolemise, inner_res_kind) = tcSplitForAllTys exp_res_kind
+
+        ; (skol_subst, tvs') <- tcInstSkolTyVars tvs_to_skolemise
+            -- we don't need to do anything substantive with the tvs' because the
+            -- quantifyTyVars in tcFamTyPats will catch them.
+
+        ; let inner_res_kind' = substTyAddInScope skol_subst inner_res_kind
+              tv_prs          = zip (map tyVarName tvs_to_skolemise) tvs'
+              skol_info       = SigSkol (InstDeclCtxt False) exp_res_kind tv_prs
+
+        ; (ev_binds, (_, new_args, co))
+            <- solveEqualities $
+               checkConstraints skol_info tvs' [] $
+               checkExpectedKindX mb_kind_env pp_fam_app
+                                  bogus_ty res_k inner_res_kind'
+
+        ; let Pair lhs_ki rhs_ki = tcCoercionKind co
+
+        ; when debugIsOn $
+          do { (_, ev_binds) <- initZonkEnv zonkTcEvBinds ev_binds
+             ; MASSERT( isEmptyTcEvBinds ev_binds )
+             ; lhs_ki <- zonkTcType lhs_ki
+             ; rhs_ki <- zonkTcType rhs_ki
+             ; MASSERT( lhs_ki `tcEqType` rhs_ki ) }
+
+        ; return (new_args, lhs_ki) }
   where
-    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats
+    bogus_ty   = pprPanic "kcDataDefn" (ppr fam_name <+> ppr pats)
+    pp_fam_app = pprFamInstLHS fam_name pats fixity (unLoc ctxt) mb_kind
+kcDataDefn _ (DataFamInstDecl (XHsImplicitBndrs _)) _
+  = panic "kcDataDefn"
+kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ (XHsDataDefn _)))) _
+  = panic "kcDataDefn"
+kcDataDefn _ (DataFamInstDecl (HsIB _ (XFamEqn _))) _
+  = panic "kcDataDefn"
 
 {-
 Kind check type patterns and kind annotate the embedded type variables.
@@ -1213,23 +1573,27 @@ Kind check type patterns and kind annotate the embedded type variables.
    not check whether there is a pattern for each type index; the latter
    check is only required for type synonym instances.
 
-Note [tc_fam_ty_pats vs tcFamTyPats]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tc_fam_ty_pats does the type checking of the patterns, but it doesn't
-zonk or generate any desugaring. It is used when kind-checking closed
-type families.
+Note [Instantiating a family tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's possible that kind-checking the result of a family tycon applied to
+its patterns will instantiate the tycon further. For example, we might
+have
 
-tcFamTyPats type checks the patterns, zonks, and then calls thing_inside
-to generate a desugaring. It is used during type-checking (not kind-checking).
+  type family F :: k where
+    F = Int
+    F = Maybe
 
-Note [Type-checking type patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking the patterns of a family instance declaration, we can't
-rely on using the family TyCon, because this is sometimes called
-from within a type-checking knot. (Specifically for closed type families.)
-The type FamTyConShape gives just enough information to do the job.
+After checking (F :: forall k. k) (with no visible patterns), we still need
+to instantiate the k. With data family instances, this problem can be even
+more intricate, due to Note [Arity of data families] in FamInstEnv. See
+indexed-types/should_compile/T12369 for an example.
+
+So, the kind-checker must return both the new args (that is, Type
+(Type -> Type) for the equations above) and the instantiated kind.
 
-See also Note [tc_fam_ty_pats vs tcFamTyPats]
+Because we don't need this information in the kind-checking phase of
+checking closed type families, we don't require these extra pieces of
+information in tc_fam_ty_pats.
 
 Note [Failing early in kcDataDefn]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1245,22 +1609,38 @@ two bad things could happen:
 -}
 
 -----------------
-type FamTyConShape = (Name, Arity, [TyConBinder], Kind)
-  -- See Note [Type-checking type patterns]
-
-famTyConShape :: TyCon -> FamTyConShape
-famTyConShape fam_tc
-  = ( tyConName fam_tc
-    , length $ filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
-    , tyConBinders fam_tc
-    , tyConResKind fam_tc )
-
-tc_fam_ty_pats :: FamTyConShape
-               -> Maybe ClsInstInfo
-               -> HsTyPats GhcRn      -- Patterns
-               -> (TcKind -> TcM ())  -- Kind checker for RHS
-                                      -- result is ignored
-               -> TcM ([Type], Kind)
+kcFamTyPats :: TcTyCon
+            -> [Name]
+            -> HsTyPats GhcRn
+            -> (TcKind -> TcM ())
+            -> TcM ()
+kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker
+  = discardResult $
+    kcImplicitTKBndrs tv_names $
+    do { let name     = tyConName tc_fam_tc
+             loc      = nameSrcSpan name
+             lhs_fun  = L loc (HsTyVar noExt NotPromoted (L loc name))
+                        -- lhs_fun is for error messages only
+             no_fun   = pprPanic "kcFamTyPats" (ppr name)
+             fun_kind = tyConKind tc_fam_tc
+
+       ; (_, _, res_kind_out) <- tcInferApps typeLevelMode Nothing lhs_fun no_fun
+                                             fun_kind arg_pats
+       ; traceTc "kcFamTyPats" (vcat [ ppr tc_fam_tc, ppr arg_pats, ppr res_kind_out ])
+       ; kind_checker res_kind_out }
+
+tcFamTyPats :: TyCon
+            -> Maybe ClsInstInfo
+            -> [Name]          -- Implicitly bound kind/type variable names
+            -> HsTyPats GhcRn  -- Type patterns
+            -> (TcKind -> TcM ([TcType], TcKind))
+                -- kind-checker for RHS
+                -- See Note [Instantiating a family tycon]
+            -> (   [TcTyVar]         -- Kind and type variables
+                -> [TcType]          -- Kind and type arguments
+                -> TcKind
+                -> TcM a)            -- NB: You can use solveEqualities here.
+            -> TcM a
 -- Check the type patterns of a type or data family instance
 --     type instance F <pat1> <pat2> = <type>
 -- The 'tyvars' are the free type variables of pats
@@ -1271,46 +1651,41 @@ tc_fam_ty_pats :: FamTyConShape
 --          type F [a] = ...
 -- In that case, the type variable 'a' will *already be in scope*
 -- (and, if C is poly-kinded, so will its kind parameter).
-
-tc_fam_ty_pats (name, _, binders, res_kind) mb_clsinfo
-               (HsIB { hsib_body = arg_pats, hsib_vars = tv_names })
-               kind_checker
-  = do { -- Kind-check and quantify
-         -- See Note [Quantifying over family patterns]
-         (_, (insted_res_kind, typats)) <- tcImplicitTKBndrs tv_names $
-         do { (insting_subst, _leftover_binders, args, leftovers, n)
-                <- tcInferArgs name binders (thdOf3 <$> mb_clsinfo) arg_pats
-            ; case leftovers of
-                hs_ty:_ -> addErrTc $ too_many_args hs_ty n
-                _       -> return ()
-              -- don't worry about leftover_binders; TcValidity catches them
-
-            ; let insted_res_kind = substTyUnchecked insting_subst res_kind
-            ; kind_checker insted_res_kind
-            ; return ((insted_res_kind, args), emptyVarSet) }
-
-       ; return (typats, insted_res_kind) }
-  where
-    too_many_args hs_ty n
-      = hang (text "Too many parameters to" <+> ppr name <> colon)
-           2 (vcat [ ppr hs_ty <+> text "is unexpected;"
-                   , text (if n == 1 then "expected" else "expected only") <+>
-                     speakNOf (n-1) (text "parameter") ])
-
--- See Note [tc_fam_ty_pats vs tcFamTyPats]
-tcFamTyPats :: FamTyConShape
-            -> Maybe ClsInstInfo
-            -> HsTyPats GhcRn        -- patterns
-            -> (TcKind -> TcM ())    -- kind-checker for RHS
-            -> (   [TcTyVar]         -- Kind and type variables
-                -> [TcType]          -- Kind and type arguments
-                -> TcKind
-                -> TcM a)            -- NB: You can use solveEqualities here.
-            -> TcM a
-tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside
-  = do { (typats, res_kind)
+tcFamTyPats fam_tc mb_clsinfo
+            tv_names arg_pats kind_checker thing_inside
+  = do { -- First, check the arity.
+         -- If we wait until validity checking, we'll get kind
+         -- errors below when an arity error will be much easier to
+         -- understand.
+         let should_check_arity
+               | DataFamilyFlavour _ <- flav = False
+                  -- why not check data families? See [Arity of data families] in FamInstEnv
+               | otherwise                   = True
+
+       ; when should_check_arity $
+         checkTc (arg_pats `lengthIs` vis_arity) $
+         wrongNumberOfParmsErr vis_arity
+                      -- report only explicit arguments
+
+       ; (fam_used_tvs, (typats, (more_typats, res_kind)))
             <- solveEqualities $  -- See Note [Constraints in patterns]
-               tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker
+               tcImplicitQTKBndrs FamInstSkol tv_names $
+                  -- See Note [Kind-checking tyvar binders for associated types]
+               do { let loc = nameSrcSpan fam_name
+                        lhs_fun = L loc (HsTyVar noExt NotPromoted
+                                                               (L loc fam_name))
+                        fun_ty = mkTyConApp fam_tc []
+                        fun_kind = tyConKind fam_tc
+                        mb_kind_env = thdOf3 <$> mb_clsinfo
+
+                  ; (_, args, res_kind_out)
+                      <- tcInferApps typeLevelMode mb_kind_env
+                                     lhs_fun fun_ty fun_kind arg_pats
+
+                  ; traceTc "tcFamTyPats 1" (vcat [ ppr fam_tc, ppr arg_pats, ppr res_kind_out ])
+
+                  ; stuff <- kind_checker res_kind_out
+                  ; return (args, stuff) }
 
           {- TODO (RAE): This should be cleverer. Consider this:
 
@@ -1333,22 +1708,42 @@ tcFamTyPats fam_shape@(name,_,_,_) mb_clsinfo pats kind_checker thing_inside
             -- them into skolems, so that we don't subsequently
             -- replace a meta kind var with (Any *)
             -- Very like kindGeneralize
-       ; vars  <- zonkTcTypesAndSplitDepVars typats
+       ; let all_pats = typats `chkAppend` more_typats
+       ; vars  <- zonkTcTypesAndSplitDepVars all_pats
        ; qtkvs <- quantifyTyVars emptyVarSet vars
 
-       ; MASSERT( isEmptyVarSet $ coVarsOfTypes typats )
+       ; when debugIsOn $
+         do { all_pats <- mapM zonkTcType all_pats
+            ; MASSERT2( isEmptyVarSet $ coVarsOfTypes all_pats, ppr all_pats ) }
            -- This should be the case, because otherwise the solveEqualities
            -- above would fail. TODO (RAE): Update once the solveEqualities
            -- bit is cleverer.
 
-       ; traceTc "tcFamTyPats" (ppr name $$ ppr typats $$ ppr qtkvs)
-            -- Don't print out too much, as we might be in the knot
-
-       ; tcExtendTyVarEnv qtkvs $
+       ; traceTc "tcFamTyPats" (ppr (getName fam_tc)
+                                $$ ppr all_pats $$ ppr qtkvs)
+
+           -- See Note [Free-floating kind vars] in TcHsType
+       ; let all_mentioned_tvs = mkVarSet qtkvs
+                                   -- qtkvs has all the tyvars bound by LHS
+                                   -- type patterns
+             unmentioned_tvs   = filterOut (`elemVarSet` all_mentioned_tvs)
+                                           fam_used_tvs
+                                   -- If there are tyvars left over, we can
+                                   -- assume they're free-floating, since they
+                                   -- aren't bound by a type pattern
+       ; checkNoErrs $ reportFloatingKvs fam_name flav
+                                         qtkvs unmentioned_tvs
+
+       ; scopeTyVars FamInstSkol qtkvs $
             -- Extend envt with TcTyVars not TyVars, because the
             -- kind checking etc done by thing_inside does not expect
             -- to encounter TyVars; it expects TcTyVars
-         thing_inside qtkvs typats res_kind }
+         thing_inside qtkvs all_pats res_kind }
+  where
+    fam_name  = tyConName fam_tc
+    flav      = tyConFlavour fam_tc
+    vis_arity = length (tyConVisibleTyVars fam_tc)
+
 
 {-
 Note [Constraints in patterns]
@@ -1479,63 +1874,57 @@ consUseGadtSyntax _                           = False
                  -- All constructors have same shape
 
 -----------------------------------
-tcConDecls :: TyCon -> ([TyConBinder], Type)
+tcConDecls :: KnotTied TyCon -> ([KnotTied TyConBinder], KnotTied Type)
            -> [LConDecl GhcRn] -> TcM [DataCon]
   -- Why both the tycon tyvars and binders? Because the tyvars
   -- have all the names and the binders have the visibilities.
 tcConDecls rep_tycon (tmpl_bndrs, res_tmpl)
   = concatMapM $ addLocM $
-    tcConDecl rep_tycon tmpl_bndrs res_tmpl
+    tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl
+    -- It's important that we pay for tag allocation here, once per TyCon,
+    -- See Note [Constructor tag allocation], fixes #14657
 
-tcConDecl :: TyCon             -- Representation tycon. Knot-tied!
-          -> [TyConBinder] -> Type
+tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!
+          -> NameEnv ConTag
+          -> [KnotTied TyConBinder] -> KnotTied Type
                  -- Return type template (with its template tyvars)
                  --    (tvs, T tys), where T is the family TyCon
           -> ConDecl GhcRn
           -> TcM [DataCon]
 
-tcConDecl rep_tycon tmpl_bndrs res_tmpl
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
           (ConDeclH98 { con_name = name
-                      , con_qvars = hs_qvars, con_cxt = hs_ctxt
-                      , con_details = hs_details })
+                      , con_ex_tvs = explicit_tkv_nms
+                      , con_mb_cxt = hs_ctxt
+                      , con_args = hs_args })
   = addErrCtxt (dataConCtxtName [name]) $
-    do { traceTc "tcConDecl 1" (ppr name)
-
-       -- Get hold of the existential type variables
-       -- e.g. data T a = forall (b::k) f. MkT a (f b)
-       -- Here tmpl_bndrs = {a}
-       --          hs_kvs = {k}
-       --          hs_tvs = {f,b}
-       ; let (hs_kvs, hs_tvs) = case hs_qvars of
-               Nothing -> ([], [])
-               Just (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })
-                       -> (kvs, tvs)
-
-       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, field_lbls, stricts))
+    do { -- Get hold of the existential type variables
+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)
+         -- Here tmpl_bndrs = {a}
+         --      hs_qvars = HsQTvs { hsq_implicit = {k}
+         --                        , hsq_explicit = {f,b} }
+
+       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])
+
+       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))
            <- solveEqualities $
-              tcImplicitTKBndrs hs_kvs $
-              tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
-              do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
-                 ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
-                 ; btys <- tcConArgs hs_details
+              tcExplicitTKBndrs skol_info explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext hs_ctxt
+                 ; btys <- tcConArgs hs_args
                  ; field_lbls <- lookupConstructorFields (unLoc name)
                  ; let (arg_tys, stricts) = unzip btys
-                       bound_vars  = allBoundVariabless ctxt `unionVarSet`
-                                     allBoundVariabless arg_tys
-                 ; return ((exp_tvs, ctxt, arg_tys, field_lbls, stricts), bound_vars)
+                 ; return (ctxt, arg_tys, field_lbls, stricts)
                  }
 
          -- exp_tvs have explicit, user-written binding sites
-         -- imp_tvs are user-written kind variables, without an explicit binding site
          -- the kvs below are those kind variables entirely unmentioned by the user
          --   and discovered only by generalization
 
-             -- Kind generalisation
-       ; let all_user_tvs = imp_tvs ++ exp_tvs
-       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys all_user_tvs $
-                                            mkFunTys ctxt $
-                                            mkFunTys arg_tys $
-                                            unitTy)
+       ; kvs <- quantifyConDecl (mkVarSet (binderVars tmpl_bndrs))
+                                (mkSpecForAllTys exp_tvs $
+                                 mkFunTys ctxt $
+                                 mkFunTys arg_tys $
+                                 unitTy)
                  -- That type is a lie, of course. (It shouldn't end in ()!)
                  -- And we could construct a proper result type from the info
                  -- at hand. But the result would mention only the tmpl_tvs,
@@ -1543,31 +1932,35 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
                  -- we're doing this to get the right behavior around removing
                  -- any vars bound in exp_binders.
 
-       ; kvs <- quantifyTyVars (mkVarSet (binderVars tmpl_bndrs)) vars
-
              -- Zonk to Types
-       ; (ze, qkvs)      <- zonkTyBndrsX emptyZonkEnv kvs
-       ; (ze, user_qtvs) <- zonkTyBndrsX ze all_user_tvs
-       ; arg_tys         <- zonkTcTypeToTypes ze arg_tys
-       ; ctxt            <- zonkTcTypeToTypes ze ctxt
+       ; (ze, qkvs)      <- zonkTyBndrs kvs
+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs
+       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt            <- zonkTcTypesToTypesX ze ctxt
 
        ; fam_envs <- tcGetFamInstEnvs
 
        -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
        ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
        ; let
-           ex_tvs = mkTyVarBinders Inferred qkvs ++
-                    mkTyVarBinders Specified user_qtvs
+           univ_tvbs = tyConTyVarBinders tmpl_bndrs
+           univ_tvs  = binderVars univ_tvbs
+           ex_tvbs   = mkTyVarBinders Inferred qkvs ++
+                       mkTyVarBinders Specified user_qtvs
+           ex_tvs    = qkvs ++ user_qtvs
+           -- For H98 datatypes, the user-written tyvar binders are precisely
+           -- the universals followed by the existentials.
+           -- See Note [DataCon user type variable binders] in DataCon.
+           user_tvbs = univ_tvbs ++ ex_tvbs
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixH98 name hs_details
+             { is_infix <- tcConIsInfixH98 name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix rep_nm
                             stricts Nothing field_lbls
-                            (mkDataConUnivTyVarBinders tmpl_bndrs)
-                            ex_tvs
+                            univ_tvs ex_tvs user_tvbs
                             [{- no eq_preds -}] ctxt arg_tys
-                            res_tmpl rep_tycon
+                            res_tmpl rep_tycon tag_map
                   -- NB:  we put data_tc, the type constructor gotten from the
                   --      constructor type signature into the data constructor;
                   --      that way checkValidDataCon can complain if it's wrong.
@@ -1575,35 +1968,64 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr name)
        ; mapM buildOneDataCon [name]
        }
-
-tcConDecl rep_tycon tmpl_bndrs res_tmpl
-          (ConDeclGADT { con_names = names, con_type = ty })
+  where
+    skol_info = SigTypeSkol (ConArgCtxt (unLoc name))
+
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
+          (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs
+                       , con_mb_cxt = cxt, con_args = hs_args
+                       , con_res_ty = res_ty })
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
-       ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details)
-           <- tcGadtSigType (ppr names) (unLoc $ head names) ty
+       ; let (L _ name : _) = names
+             skol_info      = DataConSkol name
+
+       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
+           <- failIfEmitsConstraints $  -- we won't get another crack, and we don't
+                                        -- want an error cascade
+              tcImplicitTKBndrs skol_info implicit_tkv_nms $
+              tcExplicitTKBndrs skol_info explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext cxt
+                 ; btys <- tcConArgs hs_args
+                 ; res_ty' <- tcHsLiftedType res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, res_ty', field_lbls, stricts)
+                 }
+       ; let user_tvs = imp_tvs ++ exp_tvs
 
-       ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $
-                                            mkFunTys ctxt $
-                                            mkFunTys arg_tys $
-                                            res_ty)
-       ; tkvs <- quantifyTyVars emptyVarSet vars
+       ; tkvs <- quantifyConDecl emptyVarSet (mkSpecForAllTys user_tvs $
+                                              mkFunTys ctxt $
+                                              mkFunTys arg_tys $
+                                              res_ty)
 
              -- Zonk to Types
-       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (tkvs ++ user_tvs)
-       ; arg_tys <- zonkTcTypeToTypes ze arg_tys
-       ; ctxt    <- zonkTcTypeToTypes ze ctxt
-       ; res_ty  <- zonkTcTypeToType ze res_ty
-
-       ; let (univ_tvs, ex_tvs, eq_preds, arg_subst)
-               = rejigConRes tmpl_bndrs res_tmpl qtkvs res_ty
-             -- NB: this is a /lazy/ binding, so we pass four thunks to
+       ; (ze, tkvs)     <- zonkTyBndrs tkvs
+       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs
+       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt    <- zonkTcTypesToTypesX ze ctxt
+       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty
+
+       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)
+               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty
+             -- NB: this is a /lazy/ binding, so we pass six thunks to
              --     buildDataCon without yet forcing the guards in rejigConRes
              -- See Note [Checking GADT return types]
 
-             -- See Note [Wrong visibility for GADTs]
-             univ_bndrs = mkTyVarBinders Specified univ_tvs
-             ex_bndrs   = mkTyVarBinders Specified ex_tvs
+             -- Compute the user-written tyvar binders. These have the same
+             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.
+             -- See Note [DataCon user type variable binders] in DataCon.
+             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'
+             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'
+             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs
+
+             ctxt'      = substTys arg_subst ctxt
+             arg_tys'   = substTys arg_subst arg_tys
+             res_ty'    = substTy  arg_subst res_ty
+
 
        ; fam_envs <- tcGetFamInstEnvs
 
@@ -1611,17 +2033,14 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
        ; let
            buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixGADT name hs_details
+             { is_infix <- tcConIsInfixGADT name hs_args
              ; rep_nm   <- newTyConRepName name
 
              ; buildDataCon fam_envs name is_infix
                             rep_nm
                             stricts Nothing field_lbls
-                            univ_bndrs ex_bndrs eq_preds
-                            (substTys arg_subst ctxt)
-                            (substTys arg_subst arg_tys)
-                            (substTy  arg_subst res_ty)
-                            rep_tycon
+                            univ_tvs ex_tvs all_user_bndrs eq_preds
+                            ctxt' arg_tys' res_ty' rep_tycon tag_map
                   -- NB:  we put data_tc, the type constructor gotten from the
                   --      constructor type signature into the data constructor;
                   --      that way checkValidDataCon can complain if it's wrong.
@@ -1629,31 +2048,18 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl
        ; traceTc "tcConDecl 2" (ppr names)
        ; mapM buildOneDataCon names
        }
-
-
-tcGadtSigType :: SDoc -> Name -> LHsSigType GhcRn
-              -> TcM ( [TcTyVar], [PredType],[HsSrcBang], [FieldLabel], [Type], Type
-                     , HsConDetails (LHsType GhcRn)
-                                    (Located [LConDeclField GhcRn]) )
-tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
-  = do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
-       ; (hs_details, res_ty) <- updateGadtResult failWithTc doc hs_details' res_ty'
-       ; (imp_tvs, (exp_tvs, ctxt, arg_tys, res_ty, field_lbls, stricts))
-           <- solveEqualities $
-              tcImplicitTKBndrs vars $
-              tcExplicitTKBndrs gtvs $ \ exp_tvs ->
-              do { ctxt <- tcHsContext cxt
-                 ; btys <- tcConArgs hs_details
-                 ; ty' <- tcHsLiftedType res_ty
-                 ; field_lbls <- lookupConstructorFields name
-                 ; let (arg_tys, stricts) = unzip btys
-                       bound_vars = allBoundVariabless ctxt `unionVarSet`
-                                    allBoundVariabless arg_tys
-
-                 ; return ((exp_tvs, ctxt, arg_tys, ty', field_lbls, stricts), bound_vars)
-                 }
-       ; return (imp_tvs ++ exp_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty, hs_details)
-       }
+tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)
+  = panic "tcConDecl"
+tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl"
+
+-- | Produce the telescope of kind variables that this datacon is
+-- implicitly quantified over. Incoming type need not be zonked.
+quantifyConDecl :: TcTyCoVarSet  -- outer tvs, not to be quantified over; zonked
+                -> TcType -> TcM [TcTyVar]
+quantifyConDecl gbl_tvs ty
+  = do { ty <- zonkTcType ty
+       ; let fvs = candidateQTyVarsOfType ty
+       ; quantifyTyVars gbl_tvs fvs }
 
 tcConIsInfixH98 :: Name
              -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
@@ -1706,58 +2112,6 @@ tcConArg bty
         ; return (arg_ty, getBangStrictness bty) }
 
 {-
-Note [Wrong visibility for GADTs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GADT tyvars shouldn't all be specified, but it's hard to do much better, as
-described in #11721, which is duplicated here for convenience:
-
-Consider
-
-  data X a where
-    MkX :: b -> Proxy a -> X a
-
-According to the rules around specified vs. generalized variables around
-TypeApplications, the type of MkX should be
-
-  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a
-
-A few things to note:
-
-  * The k isn't available for TypeApplications (that's why it's in braces),
-    because it is not user-written.
-
-  * The b is quantified before the a, because b comes before a in the
-    user-written type signature for MkX.
-
-Both of these bullets are currently violated. GHCi reports MkX's type as
-
-  MkX :: forall k (a :: k) b. b -> Proxy a -> X a
-
-It turns out that this is hard to fix. The problem is that GHC expects data
-constructors to have their universal variables followed by their existential
-variables, always. And yet that's violated in the desired type for MkX.
-Furthermore, given the way that GHC deals with GADT return types ("rejigging",
-in technical parlance), it's inconvenient to get the specified/generalized
-distinction correct.
-
-Given time constraints, I'm afraid fixing this all won't make it for 8.0.
-
-Happily, there is are easy-to-articulate rules governing GHC's current (wrong)
-behavior. In a GADT-syntax data constructor:
-
-  * All kind and type variables are considered specified and available for
-    visible type application.
-
-  * Universal variables always come first, in precisely the order they appear
-    in the tycon. Note that universals that are constrained by a GADT return
-    type are missing from the datacon.
-
-  * Existential variables come next. Their order is determined by a
-    user-written forall; or, if there is none, by taking the left-to-right
-    order in the datacon's type and doing a stable topological sort. (This
-    stable topological sort step is the same as for other user-written type
-    signatures.)
-
 Note [Infix GADT constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do not currently have syntax to declare an infix constructor in GADT syntax,
@@ -1791,7 +2145,7 @@ defined yet.
 
 So, we want to make rejigConRes lazy and then check the validity of
 the return type in checkValidDataCon.  To do this we /always/ return a
-4-tuple from rejigConRes (so that we can compute the return type from it, which
+6-tuple from rejigConRes (so that we can compute the return type from it, which
 checkValidDataCon needs), but the first three fields may be bogus if
 the return type isn't valid (the last equation for rejigConRes).
 
@@ -1808,20 +2162,27 @@ errors reported in one pass.  See Trac #7175, and #10836.
 --      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
 -- In this case orig_res_ty = T (e,e)
 
-rejigConRes :: [TyConBinder] -> Type    -- Template for result type; e.g.
-                                  -- data instance T [a] b c = ...
+rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.
+                                  -- data instance T [a] b c ...
                                   --      gives template ([a,b,c], T [a] b c)
                                   -- Type must be of kind *!
-            -> [TyVar]            -- where MkT :: forall x y z. ...
-            -> Type               -- res_ty type must be of kind *
+            -> [TyVar]            -- The constructor's user-written, inferred
+                                  -- type variables
+            -> [TyVar]            -- The constructor's user-written, specified
+                                  -- type variables
+            -> KnotTied Type      -- res_ty type must be of kind *
             -> ([TyVar],          -- Universal
                 [TyVar],          -- Existential (distinct OccNames from univs)
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- inferred type variables
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- specified type variables
                 [EqSpec],      -- Equality predicates
                 TCvSubst)      -- Substitution to apply to argument types
         -- We don't check that the TyCon given in the ResTy is
         -- the same as the parent tycon, because checkValidDataCon will do it
-
-rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty
+-- NB: All arguments may potentially be knot-tied
+rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty
         -- E.g.  data T [a] b c where
         --         MkT :: forall x y z. T [(x,y)] z z
         -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs
@@ -1832,18 +2193,32 @@ rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty
         --          b              b~z
         --          z
         -- Existentials are the leftover type vars: [x,y]
-        -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], <arg-subst>)
+        -- The user-written type variables are what is listed in the forall:
+        --   [x, y, z] (all specified). We must rejig these as well.
+        --   See Note [DataCon user type variable binders] in DataCon.
+        -- So we return ( [a,b,z], [x,y]
+        --              , [], [x,y,z]
+        --              , [a~(x,y),b~z], <arg-subst> )
   | Just subst <- ASSERT( isLiftedTypeKind (typeKind res_ty) )
                   ASSERT( isLiftedTypeKind (typeKind res_tmpl) )
                   tcMatchTy res_tmpl res_ty
   = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst
         raw_ex_tvs = dc_tvs `minusList` univ_tvs
-        (arg_subst, substed_ex_tvs)
-          = mapAccumL substTyVarBndr kind_subst raw_ex_tvs
+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs
+
+        -- After rejigging the existential tyvars, the resulting substitution
+        -- gives us exactly what we need to rejig the user-written tyvars,
+        -- since the dcUserTyVarBinders invariant guarantees that the
+        -- substitution has *all* the tyvars in its domain.
+        -- See Note [DataCon user type variable binders] in DataCon.
+        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)
+        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs
+        substed_specified_tvs = subst_user_tvs dc_specified_tvs
 
         substed_eqs = map (substEqSpec arg_subst) raw_eqs
     in
-    (univ_tvs, substed_ex_tvs, substed_eqs, arg_subst)
+    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,
+     substed_eqs, arg_subst)
 
   | otherwise
         -- If the return type of the data constructor doesn't match the parent
@@ -1856,18 +2231,19 @@ rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty
         -- albeit bogus, relying on checkValidDataCon to check the
         --  bad-result-type error before seeing that the other fields look odd
         -- See Note [Checking GADT return types]
-  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], emptyTCvSubst)
+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,
+     [], emptyTCvSubst)
   where
+    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs
     tmpl_tvs = binderVars tmpl_bndrs
 
-{-
-Note [mkGADTVars]
-~~~~~~~~~~~~~~~~~
-
+{- Note [mkGADTVars]
+~~~~~~~~~~~~~~~~~~~~
 Running example:
 
 data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where
-  MkT :: T x1 * (Proxy (y :: x1), z) z
+  MkT :: forall (x1 : *) (y :: x1) (z :: *).
+         T x1 * (Proxy (y :: x1), z) z
 
 We need the rejigged type to be
 
@@ -1878,19 +2254,24 @@ We need the rejigged type to be
 
 You might naively expect that z should become a universal tyvar,
 not an existential. (After all, x1 becomes a universal tyvar.)
-The problem is that the universal tyvars must have exactly the
-same kinds as the tyConTyVars. z has kind * while b has kind k2.
+But z has kind * while b has kind k2, so the return type
+   T x1 k2 a z
+is ill-kinded.  Another way to say it is this: the universal
+tyvars must have exactly the same kinds as the tyConTyVars.
+
 So we need an existential tyvar and a heterogeneous equality
 constraint. (The b ~ z is a bit redundant with the k2 ~ * that
 comes before in that b ~ z implies k2 ~ *. I'm sure we could do
 some analysis that could eliminate k2 ~ *. But we don't do this
 yet.)
 
-The HsTypes have already been desugared to proper Types:
+The data con signature has already been fully kind-checked.
+The return type
 
   T x1 * (Proxy (y :: x1), z) z
 becomes
-  [x1 :: *, y :: x1, z :: *]. T x1 * (Proxy x1 y, z) z
+  qtkvs    = [x1 :: *, y :: x1, z :: *]
+  res_tmpl = T x1 * (Proxy x1 y, z) z
 
 We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We
 know this match will succeed because of the validity check (actually done
@@ -1955,23 +2336,30 @@ on our example:
   , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]
   , {x1 |-> x1} )
 
-`choose` looks up each tycon tyvar in the matching (it *must* be matched!). If
-it finds a bare result tyvar (the first branch of the `case` statement), it
-checks to make sure that the result tyvar isn't yet in the list of univ_tvs.
-If it is in that list, then we have a repeated variable in the return type,
-and we in fact need a GADT equality. We then check to make sure that the
-kind of the result tyvar matches the kind of the template tyvar. This
-check is what forces `z` to be existential, as it should be, explained above.
-Assuming no repeated variables or kind-changing, we wish
-to use the variable name given in the datacon signature (that is, `x1` not
-`k1`), not the tycon signature (which may have been made up by
-GHC). So, we add a mapping from the tycon tyvar to the result tyvar to t_sub.
-
-If we discover that a mapping in `subst` gives us a non-tyvar (the second
-branch of the `case` statement), then we have a GADT equality to create.
-We create a fresh equality, but we don't extend any substitutions. The
-template variable substitution is meant for use in universal tyvar kinds,
-and these shouldn't be affected by any GADT equalities.
+`choose` looks up each tycon tyvar in the matching (it *must* be matched!).
+
+* If it finds a bare result tyvar (the first branch of the `case`
+  statement), it checks to make sure that the result tyvar isn't yet
+  in the list of univ_tvs.  If it is in that list, then we have a
+  repeated variable in the return type, and we in fact need a GADT
+  equality.
+
+* It then checks to make sure that the kind of the result tyvar
+  matches the kind of the template tyvar. This check is what forces
+  `z` to be existential, as it should be, explained above.
+
+* Assuming no repeated variables or kind-changing, we wish to use the
+  variable name given in the datacon signature (that is, `x1` not
+  `k1`), not the tycon signature (which may have been made up by
+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar
+  to t_sub.
+
+* If we discover that a mapping in `subst` gives us a non-tyvar (the
+  second branch of the `case` statement), then we have a GADT equality
+  to create.  We create a fresh equality, but we don't extend any
+  substitutions. The template variable substitution is meant for use
+  in universal tyvar kinds, and these shouldn't be affected by any
+  GADT equalities.
 
 This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways
 of simplifying it:
@@ -2032,10 +2420,14 @@ mkGADTVars tmpl_tvs dc_tvs subst
               r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)
               r_ty'  = mkTyVarTy r_tv1
 
-               -- not a simple substitution. make an equality predicate
+               -- Not a simple substitution: make an equality predicate
           _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)
-                      t_sub r_sub t_tvs
-            where t_tv' = updateTyVarKind (substTy t_sub) t_tv
+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))
+                         -- We've updated the kind of t_tv,
+                         -- so add it to t_sub (Trac #14162)
+                      r_sub t_tvs
+            where
+              t_tv' = updateTyVarKind (substTy t_sub) t_tv
 
       | otherwise
       = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
@@ -2113,7 +2505,11 @@ Validity checking is done once the mutually-recursive knot has been
 tied, so we can look at things freely.
 -}
 
-checkValidTyCl :: TyCon -> TcM TyCon
+checkValidTyCl :: TyCon -> TcM [TyCon]
+-- The returned list is either a singleton (if valid)
+-- or a list of "fake tycons" (if not); the fake tycons
+-- include any implicits, like promoted data constructors
+-- See Note [Recover from validity error]
 checkValidTyCl tc
   = setSrcSpan (getSrcSpan tc) $
     addTyConCtxt tc $
@@ -2121,15 +2517,19 @@ checkValidTyCl tc
              (do { traceTc "Starting validity for tycon" (ppr tc)
                  ; checkValidTyCon tc
                  ; traceTc "Done validity for tycon" (ppr tc)
-                 ; return tc })
+                 ; return [tc] })
   where
     recovery_code -- See Note [Recover from validity error]
       = do { traceTc "Aborted validity for tycon" (ppr tc)
-           ; return fake_tc }
-    fake_tc | isFamilyTyCon tc || isTypeSynonymTyCon tc
-            = makeRecoveryTyCon tc
-            | otherwise
-            = tc
+           ; return (concatMap mk_fake_tc $
+                     ATyCon tc : implicitTyConThings tc) }
+
+    mk_fake_tc (ATyCon tc)
+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
+      | otherwise       = [makeRecoveryTyCon tc]
+    mk_fake_tc (AConLike (RealDataCon dc))
+                        = [makeRecoveryTyCon (promoteDataCon dc)]
+    mk_fake_tc _        = []
 
 {- Note [Recover from validity error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2143,14 +2543,29 @@ want to go on checking validity of subsequent type declarations.
 So we replace T with an abstract TyCon which will do no harm.
 See indexed-types/should_fail/BadSock and Trac #10896
 
-Painfully, though, we *don't* want to do this for classes.
-Consider tcfail041:
-   class (?x::Int) => C a where ...
-   instance C Int
-The class is invalid because of the superclass constraint.  But
-we still want it to look like a /class/, else the instance bleats
-that the instance is mal-formed because it hasn't got a class in
-the head.
+Some notes:
+
+* We must make fakes for promoted DataCons too. Consider (Trac #15215)
+      data T a = MkT ...
+      data S a = ...T...MkT....
+  If there is an error in the definition of 'T' we add a "fake type
+  constructor" to the type environment, so that we can continue to
+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'
+  and so there was an internal error when we met 'MkT' in the body of
+  'S'.
+
+* Painfully, we *don't* want to do this for classes.
+  Consider tcfail041:
+     class (?x::Int) => C a where ...
+     instance C Int
+  The class is invalid because of the superclass constraint.  But
+  we still want it to look like a /class/, else the instance bleats
+  that the instance is mal-formed because it hasn't got a class in
+  the head.
+
+  This is really bogus; now we have in scope a Class that is invalid
+  in some way, with unknown downstream consequences.  A better
+  alterantive might be to make a fake class TyCon.  A job for another day.
 -}
 
 -------------------------
@@ -2175,7 +2590,6 @@ checkValidTyCon tc
 
   | otherwise
   = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))
-       ; checkValidTyConTyVars tc
        ; if | Just cl <- tyConClass_maybe tc
               -> checkValidClass cl
 
@@ -2211,6 +2625,7 @@ checkValidTyCon tc
                ; let ex_ok = existential_ok || gadt_ok
                      -- Data cons can have existential context
                ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
 
                 -- Check that fields with the same name share a type
                ; mapM_ check_fields groups }}
@@ -2238,7 +2653,7 @@ checkValidTyCon tc
     -- result type against other candidates' types BOTH WAYS ROUND.
     -- If they magically agrees, take the substitution and
     -- apply them to the latter ones, and see if they match perfectly.
-    check_fields ((label, con1) : other_fields)
+    check_fields ((label, con1) :| other_fields)
         -- These fields all have the same name, but are from
         -- different constructors in the data type
         = recoverM (return ()) $ mapM_ checkOne other_fields
@@ -2250,13 +2665,35 @@ checkValidTyCon tc
         fty1 = dataConFieldType con1 lbl
         lbl = flLabel label
 
-        checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
+        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical
             = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
                  ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
             where
                 (_, _, _, res2) = dataConSig con2
                 fty2 = dataConFieldType con2 lbl
-    check_fields [] = panic "checkValidTyCon/check_fields []"
+
+checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
+-- Checks the partial record field selector, and warns.
+-- See Note [Checking partial record field]
+checkPartialRecordField all_cons fld
+  = setSrcSpan loc $
+      warnIfFlag Opt_WarnPartialFields
+        (not is_exhaustive && not (startsWithUnderscore occ_name))
+        (sep [text "Use of partial record field selector" <> colon,
+              nest 2 $ quotes (ppr occ_name)])
+  where
+    sel_name = flSelector fld
+    loc    = getSrcSpan sel_name
+    occ_name = getOccName sel_name
+
+    (cons_with_field, cons_without_field) = partition has_field all_cons
+    has_field con = fld `elem` (dataConFieldLabels con)
+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
+
+    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
 
 checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
                  -> Type -> Type -> Type -> Type -> TcM ()
@@ -2268,59 +2705,10 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
     mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
 
 -------------------------------
--- | Check for ill-scoped telescopes in a tycon.
--- For example:
---
--- > data SameKind :: k -> k -> *   -- this is OK
--- > data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
---
--- The problem is that @b@ should be bound (implicitly) at the beginning,
--- but its kind mentions @a@, which is not yet in scope. Kind generalization
--- makes a mess of this, and ends up including @a@ twice in the final
--- tyvars. So this function checks for duplicates and, if there are any,
--- produces the appropriate error message.
-checkValidTyConTyVars :: TyCon -> TcM ()
-checkValidTyConTyVars tc
-  = do { -- strip off the duplicates and look for ill-scoped things
-         -- but keep the *last* occurrence of each variable, as it's
-         -- most likely the one the user wrote
-         let stripped_tvs | duplicate_vars
-                          = reverse $ nub $ reverse tvs
-                          | otherwise
-                          = tvs
-             vis_tvs      = filterOutInvisibleTyVars tc tvs
-             extra | not (vis_tvs `equalLength` stripped_tvs)
-                   = text "NB: Implicitly declared kind variables are put first."
-                   | otherwise
-                   = empty
-       ; checkValidTelescope (pprTyVars vis_tvs) stripped_tvs extra
-         `and_if_that_doesn't_error`
-           -- This triggers on test case dependent/should_fail/InferDependency
-           -- It reports errors around Note [Dependent LHsQTyVars] in TcHsType
-         when duplicate_vars (
-          addErr (vcat [ text "Invalid declaration for" <+>
-                         quotes (ppr tc) <> semi <+> text "you must explicitly"
-                       , text "declare which variables are dependent on which others."
-                       , hang (text "Inferred variable kinds:")
-                         2 (vcat (map pp_tv stripped_tvs)) ])) }
-  where
-    tvs = tyConTyVars tc
-    duplicate_vars = tvs `lengthExceeds` sizeVarSet (mkVarSet tvs)
-
-    pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-
-     -- only run try_second if the first reports no errors
-    and_if_that_doesn't_error :: TcM () -> TcM () -> TcM ()
-    try_first `and_if_that_doesn't_error` try_second
-      = recoverM (return ()) $
-        do { checkNoErrs try_first
-           ; try_second }
-
--------------------------------
 checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
 checkValidDataCon dflags existential_ok tc con
-  = setSrcSpan (srcLocSpan (getSrcLoc con))     $
-    addErrCtxt (dataConCtxt con)                $
+  = setSrcSpan (getSrcSpan con)  $
+    addErrCtxt (dataConCtxt con) $
     do  { -- Check that the return type of the data constructor
           -- matches the type constructor; eg reject this:
           --   data T a where { MkT :: Bogus a }
@@ -2367,7 +2755,31 @@ checkValidDataCon dflags existential_ok tc con
           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
         ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
 
-        ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))
+          -- Check the dcUserTyVarBinders invariant
+          -- See Note [DataCon user type variable binders] in DataCon
+          -- checked here because we sometimes build invalid DataCons before
+          -- erroring above here
+        ; when debugIsOn $
+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con
+                   user_tvs                       = dataConUserTyVars con
+                   user_tvbs_invariant
+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)
+                       == Set.fromList user_tvs
+             ; MASSERT2( user_tvbs_invariant
+                       , vcat ([ ppr con
+                               , ppr univs
+                               , ppr exs
+                               , ppr eq_spec
+                               , ppr user_tvs ])) }
+
+        ; traceTc "Done validity of data con" $
+          vcat [ ppr con
+               , text "Datacon user type:" <+> ppr (dataConUserType con)
+               , text "Datacon rep type:" <+> ppr (dataConRepType con)
+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
+               , case tyConFamInst_maybe (dataConTyCon con) of
+                   Nothing -> text "not family"
+                   Just (f, _) -> ppr (tyConBinders f) ]
     }
   where
     ctxt = ConArgCtxt (dataConName con)
@@ -2382,9 +2794,17 @@ checkValidDataCon dflags existential_ok tc con
       = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
       | isSrcUnpacked want_unpack
       , case rep_bang of { HsUnpack {} -> False; _ -> True }
+      -- If not optimising, we don't unpack (rep_bang is never
+      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.
+      -- See dataConSrcToImplBang.
       , not (gopt Opt_OmitInterfacePragmas dflags)
-           -- If not optimising, se don't unpack, so don't complain!
-           -- See MkId.dataConArgRep, the (HsBang True) case
+      -- When typechecking an indefinite package in Backpack, we
+      -- may attempt to UNPACK an abstract type.  The test here will
+      -- conclude that this is unusable, but it might become usable
+      -- when we actually fill in the abstract type.  As such, don't
+      -- warn in this case (it gives users the wrong idea about whether
+      -- or not UNPACK on abstract types is supported; it is!)
+      , unitIdIsDefinite (thisPackage dflags)
       = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
       where
         is_strict = case strict_mark of
@@ -2472,7 +2892,7 @@ checkValidClass cls
         ; mapM_ check_at at_stuff  }
   where
     (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
-    cls_arity = length $ filterOutInvisibleTyVars (classTyCon cls) tyvars
+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))
        -- Ignore invisible variables
     cls_tv_set = mkVarSet tyvars
     mini_env   = zipVarEnv tyvars (mkTyVarTys tyvars)
@@ -2528,9 +2948,10 @@ checkValidClass cls
              -- Check that any default declarations for associated types are valid
            ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->
              checkValidTyFamEqn mb_cls fam_tc
-                                fam_tvs [] (mkTyVarTys fam_tvs) rhs loc }
+                                fam_tvs [] (mkTyVarTys fam_tvs) rhs pp_lhs loc }
         where
           fam_tvs = tyConTyVars fam_tc
+          pp_lhs  = ppr (mkTyConApp fam_tc (mkTyVarTys fam_tvs))
 
     check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
     -- Check validity of the /top-level/ generic-default type
@@ -2618,14 +3039,14 @@ checkFamFlag tc_name
        ; checkTc idx_tys err_msg }
   where
     err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
-                 2 (text "Use TypeFamilies to allow indexed type families")
+                 2 (text "Enable TypeFamilies to allow indexed type families")
 
 {- Note [Class method constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Haskell 2010 is supposed to reject
   class C a where
     op :: Eq a => a -> a
-where the method type costrains only the class variable(s).  (The extension
+where the method type constrains only the class variable(s).  (The extension
 -XConstrainedClassMethods switches off this check.)  But regardless
 we should not reject
   class C a where
@@ -2780,6 +3201,92 @@ tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it
 sees until it can't go any further, so if you called it on the default type
 signature for `each`, it would return (a -> f b) -> s -> f t like we desired.
 
+Note [Checking partial record field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This check checks the partial record field selector, and warns (Trac #7169).
+
+For example:
+
+  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }
+
+The function 'm2' is partial record field, and will fail when it is applied to
+'B'. The warning identifies such partial fields. The check is performed at the
+declaration of T, not at the call-sites of m2.
+
+The warning can be suppressed by prefixing the field-name with an underscore.
+For example:
+
+  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }
+
+Note [checkValidDependency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Proxy k (a :: k)
+  data Proxy2 k a = P (Proxy k a)
+
+(This is test dependent/should_fail/InferDependency.) While it seems GHC can
+figure out the dependency between the arguments to Proxy2, this case errors.
+The problem is that when we build the initial kind (getInitialKind) for
+a tycon, we need to decide whether an argument is dependent or not. At first,
+I thought we could just assume that *all* arguments are dependent, and then
+patch it up later. However, this causes problems in error messages (where
+tycon's have mysterious kinds "forall (a :: k) -> blah") and in unification
+(where we try to unify kappa ~ forall (a :: k) -> blah, failing because the
+RHS is not a tau-type). Perhaps a cleverer algorithm could sort this out
+(say, by storing the dependency flag in a mutable cell and by avoiding
+these fancy kinds in error messages depending on the extension in effect)
+but it doesn't seem worth it.
+
+So: we choose the dependency for each argument variable once and for all
+in getInitialKind. This means that any dependency must be lexically manifest.
+
+checkValidDependency checks to make sure that no lexically non-dependent
+argument actually appears in a kind. Note the example above, where the k
+in Proxy2 is a dependent argument, but this fact is not lexically
+manifest. checkValidDependency will reject. This function must be called
+*before* kind generalization, because kind generalization works with
+the result of mkTyConKind, which will think that Proxy2's kind is
+Type -> k -> Type, where k is unbound. (It won't use a forall for a
+"non-dependent" argument k.)
+-}
+
+-- | See Note [checkValidDependency]
+checkValidDependency :: [TyConBinder]  -- zonked
+                     -> TcKind         -- zonked (result kind)
+                     -> TcM ()
+checkValidDependency binders res_kind
+  = go (tyCoVarsOfType res_kind) (reverse binders)
+  where
+    go :: TyCoVarSet     -- fvs from scope
+       -> [TyConBinder]  -- binders, in reverse order
+       -> TcM ()
+    go _   []           = return ()  -- all set
+    go fvs (tcb : tcbs)
+      | not (isNamedTyConBinder tcb) && tcb_var `elemVarSet` fvs
+      = do { setSrcSpan (getSrcSpan tcb_var) $
+             addErrTc (vcat [ text "Type constructor argument" <+> quotes (ppr tcb_var) <+>
+                              text "is used dependently."
+                            , text "Any dependent arguments must be obviously so, not inferred"
+                            , text "by the type-checker."
+                            , hang (text "Inferred argument kinds:")
+                                 2 (vcat (map pp_binder binders))
+                            , text "Suggestion: use" <+> quotes (ppr tcb_var) <+>
+                              text "in a kind to make the dependency clearer." ])
+           ; go new_fvs tcbs }
+
+      | otherwise
+      = go new_fvs tcbs
+      where
+        new_fvs = fvs `delVarSet` tcb_var
+                      `unionVarSet` tyCoVarsOfType tcb_kind
+
+        tcb_var  = binderVar tcb
+        tcb_kind = tyVarKind tcb_var
+
+        pp_binder binder = ppr (binderVar binder) <+> dcolon <+> ppr (binderType binder)
+
+{-
 ************************************************************************
 *                                                                      *
                 Checking role validity
@@ -2807,7 +3314,7 @@ checkValidRoleAnnots role_annots tc
 
     check_roles
       = whenIsJust role_annot_decl_maybe $
-          \decl@(L loc (RoleAnnotDecl _ the_role_annots)) ->
+          \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->
           addRoleAnnotCtxt name $
           setSrcSpan loc $ do
           { role_annots_ok <- xoptM LangExt.RoleAnnotations
@@ -2817,7 +3324,7 @@ checkValidRoleAnnots role_annots tc
           ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
           -- Representational or phantom roles for class parameters
           -- quickly lead to incoherence. So, we require
-          -- IncoherentInstances to have them. See #8773.
+          -- IncoherentInstances to have them. See #8773, #14292
           ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
           ; checkTc (  incoherent_roles_ok
                     || (not $ isClassTyCon tc)
@@ -2863,6 +3370,10 @@ checkValidRoles tc
         ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)
         role_env   = univ_roles `plusVarEnv` ex_roles
 
+    check_ty_roles env role ty
+      | Just ty' <- coreView ty -- #14101
+      = check_ty_roles env role ty'
+
     check_ty_roles env role (TyVarTy tv)
       = case lookupVarEnv env tv of
           Just role' -> unless (role' `ltRole` role || role' == role) $
@@ -2890,7 +3401,7 @@ checkValidRoles tc
       =  check_ty_roles env role ty1
       >> check_ty_roles env role ty2
 
-    check_ty_roles env role (ForAllTy (TvBndr tv _) ty)
+    check_ty_roles env role (ForAllTy (Bndr tv _) ty)
       =  check_ty_roles env Nominal (tyVarKind tv)
       >> check_ty_roles (extendVarEnv env tv Nominal) role ty
 
@@ -2925,9 +3436,12 @@ tcAddTyFamInstCtxt decl
   = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
 
 tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
-tcMkDataFamInstCtxt decl
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
+                            HsIB { hsib_body = eqn }})
   = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
-                    (unLoc (dfid_tycon decl))
+                    (unLoc (feqn_tycon eqn))
+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "tcMkDataFamInstCtxt"
 
 tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
 tcAddDataFamInstCtxt decl
@@ -2980,20 +3494,20 @@ classArityErr n cls
   where
     mkErr howMany allowWhat =
         vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),
-              parens (text ("Use MultiParamTypeClasses to allow "
+              parens (text ("Enable MultiParamTypeClasses to allow "
                                     ++ allowWhat ++ " classes"))]
 
 classFunDepsErr :: Class -> SDoc
 classFunDepsErr cls
   = vcat [text "Fundeps in class" <+> quotes (ppr cls),
-          parens (text "Use FunctionalDependencies to allow fundeps")]
+          parens (text "Enable FunctionalDependencies to allow fundeps")]
 
 badMethPred :: Id -> TcPredType -> SDoc
 badMethPred sel_id pred
   = vcat [ hang (text "Constraint" <+> quotes (ppr pred)
                  <+> text "in the type of" <+> quotes (ppr sel_id))
               2 (text "constrains only the class type variables")
-         , text "Use ConstrainedClassMethods to allow it" ]
+         , text "Enable ConstrainedClassMethods to allow it" ]
 
 noClassTyVarErr :: Class -> TyCon -> SDoc
 noClassTyVarErr clas fam_tc
@@ -3003,21 +3517,64 @@ noClassTyVarErr clas fam_tc
 
 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
 badDataConTyCon data_con res_ty_tmpl actual_res_ty
+  | ASSERT( all isTyVar actual_ex_tvs )
+    tcIsForAllTy actual_res_ty
+  = nested_foralls_contexts_suggestion
+  | isJust (tcSplitPredFunTy_maybe actual_res_ty)
+  = nested_foralls_contexts_suggestion
+  | otherwise
   = hang (text "Data constructor" <+> quotes (ppr data_con) <+>
                 text "returns type" <+> quotes (ppr actual_res_ty))
        2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))
+  where
+    -- This suggestion is useful for suggesting how to correct code like what
+    -- was reported in Trac #12087:
+    --
+    --   data F a where
+    --     MkF :: Ord a => Eq a => a -> F a
+    --
+    -- Although nested foralls or contexts are allowed in function type
+    -- signatures, it is much more difficult to engineer GADT constructor type
+    -- signatures to allow something similar, so we error in the latter case.
+    -- Nevertheless, we can at least suggest how a user might reshuffle their
+    -- exotic GADT constructor type signature so that GHC will accept.
+    nested_foralls_contexts_suggestion =
+      text "GADT constructor type signature cannot contain nested"
+      <+> quotes forAllLit <> text "s or contexts"
+      $+$ hang (text "Suggestion: instead use this type signature:")
+             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)
+
+    -- To construct a type that GHC would accept (suggested_ty), we:
+    --
+    -- 1) Find the existentially quantified type variables and the class
+    --    predicates from the datacon. (NB: We don't need the universally
+    --    quantified type variables, since rejigConRes won't substitute them in
+    --    the result type if it fails, as in this scenario.)
+    -- 2) Split apart the return type (which is headed by a forall or a
+    --    context) using tcSplitNestedSigmaTys, collecting the type variables
+    --    and class predicates we find, as well as the rho type lurking
+    --    underneath the nested foralls and contexts.
+    -- 3) Smash together the type variables and class predicates from 1) and
+    --    2), and prepend them to the rho type from 2).
+    actual_ex_tvs = dataConExTyCoVars data_con
+    actual_theta  = dataConTheta data_con
+    (actual_res_tvs, actual_res_theta, actual_res_rho)
+      = tcSplitNestedSigmaTys actual_res_ty
+    suggested_ty = mkSpecForAllTys (actual_ex_tvs ++ actual_res_tvs) $
+                   mkFunTys (actual_theta ++ actual_res_theta)
+                   actual_res_rho
 
 badGadtDecl :: Name -> SDoc
 badGadtDecl tc_name
   = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)
-         , nest 2 (parens $ text "Use GADTs to allow GADTs") ]
+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]
 
 badExistential :: DataCon -> SDoc
 badExistential con
   = hang (text "Data constructor" <+> quotes (ppr con) <+>
                 text "has existential type variables, a context, or a specialised result type")
        2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)
-               , parens $ text "Use ExistentialQuantification or GADTs to allow this" ])
+               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])
 
 badStupidTheta :: Name -> SDoc
 badStupidTheta tc_name
@@ -3082,18 +3639,20 @@ badRoleAnnot var annot inferred
               , text "is required" ])
 
 wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc
-wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots))
+wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))
   = hang (text "Wrong number of roles listed in role annotation;" $$
           text "Expected" <+> (ppr $ length tyvars) <> comma <+>
           text "got" <+> (ppr $ length annots) <> colon)
        2 (ppr d)
+wrongNumberOfRoles _ (L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"
 
 illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
-illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _))
+illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))
   = setErrCtxt [] $
     setSrcSpan loc $
     addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
               text "they are allowed only for datatypes and classes.")
+illegalRoleAnnotDecl (L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"
 
 needXRoleAnnotations :: TyCon -> SDoc
 needXRoleAnnotations tc
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 68e15fbd48..f64b9f3e73 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -19,18 +19,20 @@ module TcTyDecls(
         checkClassCycles,
 
         -- * Implicits
-        tcAddImplicits, mkDefaultMethodType,
+        addTyConsToGblEnv, mkDefaultMethodType,
 
         -- * Record selectors
-        mkRecSelBinds, mkOneRecordSelector
+        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnMonad
 import TcEnv
-import TcBinds( tcRecSelBinds )
-import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )
+import TcBinds( tcValBinds, addTypecheckedBinds )
+import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
 import TcType
 import TysWiredIn( unitTy )
 import MkCore( rEC_SEL_ERROR_ID )
@@ -109,20 +111,24 @@ synonymTyConsOfType ty
      -- in the same recursive group.  Possibly this restriction will be
      -- lifted in the future but for now, this code is "just for completeness
      -- sake".
-     go_co (Refl _ ty)            = go ty
+     go_mco MRefl    = emptyNameEnv
+     go_mco (MCo co) = go_co co
+
+     go_co (Refl ty)              = go ty
+     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco
      go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs
      go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'
      go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'
      go_co (FunCo _ co co')       = go_co co `plusNameEnv` go_co co'
      go_co (CoVarCo _)            = emptyNameEnv
+     go_co (HoleCo {})            = emptyNameEnv
      go_co (AxiomInstCo _ _ cs)   = go_co_s cs
      go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
      go_co (SymCo co)             = go_co co
      go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'
-     go_co (NthCo _ co)           = go_co co
+     go_co (NthCo _ _ co)         = go_co co
      go_co (LRCo _ co)            = go_co co
      go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'
-     go_co (CoherenceCo co co')   = go_co co `plusNameEnv` go_co co'
      go_co (KindCo co)            = go_co co
      go_co (SubCo co)             = go_co co
      go_co (AxiomRuleCo _ cs)     = go_co_s cs
@@ -131,7 +137,6 @@ synonymTyConsOfType ty
      go_prov (PhantomProv co)     = go_co co
      go_prov (ProofIrrelProv co)  = go_co co
      go_prov (PluginProv _)       = emptyNameEnv
-     go_prov (HoleProv _)         = emptyNameEnv
 
      go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
               | otherwise             = emptyNameEnv
@@ -479,7 +484,7 @@ initialRoleEnv1 hsc_src annots_env tc
           -- is wrong, just ignore it. We check this in the validity check.
         role_annots
           = case lookupRoleAnnot annots_env name of
-              Just (L _ (RoleAnnotDecl _ annots))
+              Just (L _ (RoleAnnotDecl _ _ annots))
                 | annots `lengthIs` num_exps -> map unLoc annots
               _                              -> replicate num_exps Nothing
         default_roles = build_default_roles argflags role_annots
@@ -580,6 +585,8 @@ irDataCon datacon
 irType :: VarSet -> Type -> RoleM ()
 irType = go
   where
+    go lcls ty                 | Just ty' <- coreView ty -- #14101
+                               = go lcls ty'
     go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $
                                  updateRole Representational tv
     go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2
@@ -739,23 +746,24 @@ updateRoleEnv name n role
 *                                                                      *
 ********************************************************************* -}
 
-tcAddImplicits :: [TyCon] -> TcM TcGblEnv
+addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
 -- Given a [TyCon], add to the TcGblEnv
+--   * extend the TypeEnv with the tycons
 --   * extend the TypeEnv with their implicitTyThings
 --   * extend the TypeEnv with any default method Ids
 --   * add bindings for record selectors
---   * add bindings for type representations for the TyThings
-tcAddImplicits tycons
-  = discardWarnings $
+addTyConsToGblEnv tyclss
+  = tcExtendTyConEnv tyclss                    $
     tcExtendGlobalEnvImplicit implicit_things  $
     tcExtendGlobalValEnv def_meth_ids          $
-    do { traceTc "tcAddImplicits" $ vcat
-            [ text "tycons" <+> ppr tycons
+    do { traceTc "tcAddTyCons" $ vcat
+            [ text "tycons" <+> ppr tyclss
             , text "implicits" <+> ppr implicit_things ]
-       ; tcRecSelBinds (mkRecSelBinds tycons) }
+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+       ; return gbl_env }
  where
-   implicit_things = concatMap implicitTyConThings tycons
-   def_meth_ids    = mkDefaultMethodIds tycons
+   implicit_things = concatMap implicitTyConThings tyclss
+   def_meth_ids    = mkDefaultMethodIds tyclss
 
 mkDefaultMethodIds :: [TyCon] -> [Id]
 -- We want to put the default-method Ids (both vanilla and generic)
@@ -771,10 +779,18 @@ mkDefaultMethodIds tycons
 mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
 -- Returns the top-level type of the default method
 mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id
-mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSpecSigmaTy cls_tvs [pred] dm_ty
+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty
    where
-     cls_tvs = classTyVars cls
-     pred    = mkClassPred cls (mkTyVarTys cls_tvs)
+     pred      = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs))
+     cls_bndrs = tyConBinders (classTyCon cls)
+     tv_bndrs  = tyConTyVarBinders cls_bndrs
+     -- NB: the Class doesn't have TyConBinders; we reach into its
+     --     TyCon to get those.  We /do/ need the TyConBinders because
+     --     we need the correct visibility: these default methods are
+     --     used in code generated by the fill-in for missing
+     --     methods in instances (TcInstDcls.mkDefMethBind), and
+     --     then typechecked.  So we need the right visibilty info
+     --     (Trac #13998)
 
 {-
 ************************************************************************
@@ -810,30 +826,37 @@ when typechecking the [d| .. |] quote, and typecheck them later.
 ************************************************************************
 -}
 
-mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn
+tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
+tcRecSelBinds sel_bind_prs
+  = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
+    do { (rec_sel_binds, tcg_env) <- discardWarnings $
+                                     tcValBinds TopLevel binds sigs getGblEnv
+       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+  where
+    sigs = [ L loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs
+                                          , let loc = getSrcSpan sel_id ]
+    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
+
+mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
 --    This makes life easier, because the later type checking will add
 --    all necessary type abstractions and applications
 mkRecSelBinds tycons
-  = ValBindsOut binds sigs
-  where
-    (sigs, binds) = unzip rec_sels
-    rec_sels = map mkRecSelBind [ (tc,fld)
-                                | tc <- tycons
+  = map mkRecSelBind [ (tc,fld) | tc <- tycons
                                 , fld <- tyConFieldLabels tc ]
 
-mkRecSelBind :: (TyCon, FieldLabel) -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn))
+mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
 mkRecSelBind (tycon, fl)
   = mkOneRecordSelector all_cons (RecSelData tycon) fl
   where
     all_cons = map RealDataCon (tyConDataCons tycon)
 
 mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-                    -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn))
+                    -> (Id, LHsBind GhcRn)
 mkOneRecordSelector all_cons idDetails fl
-  = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))
+  = (sel_id, L loc sel_bind)
   where
-    loc    = getSrcSpan sel_name
+    loc      = getSrcSpan sel_name
     lbl      = flLabel fl
     sel_name = flSelector fl
 
@@ -870,13 +893,14 @@ mkOneRecordSelector all_cons idDetails fl
              | otherwise =  map mk_match cons_w_field ++ deflt
     mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
                                  [L loc (mk_sel_pat con)]
-                                 (L loc (HsVar (L loc field_var)))
+                                 (L loc (HsVar noExt (L loc field_var)))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
     rec_field  = noLoc (HsRecField
                         { hsRecFieldLbl
-                           = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name)
-                        , hsRecFieldArg = L loc (VarPat (L loc field_var))
+                           = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl))
+                        , hsRecFieldArg
+                           = L loc (VarPat noExt (L loc field_var))
                         , hsRecPun = False })
     sel_lname = L loc sel_name
     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
@@ -886,10 +910,10 @@ mkOneRecordSelector all_cons idDetails fl
     -- mentions this particular record selector
     deflt | all dealt_with all_cons = []
           | otherwise = [mkSimpleMatch CaseAlt
-                            [L loc (WildPat placeHolderType)]
-                            (mkHsApp (L loc (HsVar
+                            [L loc (WildPat noExt)]
+                            (mkHsApp (L loc (HsVar noExt
                                             (L loc (getName rEC_SEL_ERROR_ID))))
-                                     (L loc (HsLit msg_lit)))]
+                                     (L loc (HsLit noExt msg_lit)))]
 
         -- Do not add a default case unless there are unmatched
         -- constructors.  We must take account of GADTs, else we
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index e12b70b6d1..e6cd0731e5 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -15,7 +15,7 @@ The "tc" prefix is for "TypeChecker", because the type checker
 is the principal client.
 -}
 
-{-# LANGUAGE CPP, MultiWayIf, FlexibleContexts #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}
 
 module TcType (
   --------------------------------
@@ -23,6 +23,7 @@ module TcType (
   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
   TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
   TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon,
+  KnotTied,
 
   ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,
 
@@ -30,35 +31,35 @@ module TcType (
 
   -- TcLevel
   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
-  strictlyDeeperThan, sameDepthAs, fmvTcLevel,
+  strictlyDeeperThan, sameDepthAs,
   tcTypeLevel, tcTyVarLevel, maxTcLevel,
-
+  promoteSkolem, promoteSkolemX, promoteSkolemsX,
   --------------------------------
   -- MetaDetails
   UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
   TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
   MetaDetails(Flexi, Indirect), MetaInfo(..),
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
-  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,
+  tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,
   isFskTyVar, isFmvTyVar, isFlattenTyVar,
   isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,
   isFlexi, isIndirect, isRuntimeUnkSkol,
   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
-  isTouchableMetaTyVar, isTouchableOrFmv,
+  isTouchableMetaTyVar,
   isFloatedTouchableMetaTyVar,
+  findDupTyVarTvs, mkTyVarNamePairs,
 
   --------------------------------
   -- Builders
   mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy,
-  mkNakedTyConApp, mkNakedAppTys, mkNakedAppTy,
-  mkNakedCastTy,
+  mkNakedAppTy, mkNakedAppTys, mkNakedCastTy, nakedSubstTy,
 
   --------------------------------
   -- Splitters
   -- These are important because they do not look through newtypes
   getTyVar,
   tcSplitForAllTy_maybe,
-  tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs,
+  tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,
   tcSplitPhiTy, tcSplitPredFunTy_maybe,
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
   tcSplitFunTysN,
@@ -66,7 +67,8 @@ module TcType (
   tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_maybe',
   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
-  tcGetTyVar_maybe, tcGetTyVar, nextRole,
+  tcRepGetNumAppTys,
+  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,
   tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
 
   ---------------------------------
@@ -77,10 +79,10 @@ module TcType (
   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
-  isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
-  isPredTy, isTyVarClassPred, isTyVarExposed, isInsolubleOccursCheck,
+  hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+  isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
   checkValidClsArgs, hasTyVarHead,
-  isRigidEqPred, isRigidTy,
+  isRigidTy,
 
   ---------------------------------
   -- Misc type manipulators
@@ -99,16 +101,13 @@ module TcType (
   isImprovementPred,
 
   -- * Finding type instances
-  tcTyFamInsts,
+  tcTyFamInsts, isTyFamFree,
 
   -- * Finding "exact" (non-dead) type variables
   exactTyCoVarsOfType, exactTyCoVarsOfTypes,
   candidateQTyVarsOfType, candidateQTyVarsOfTypes, CandidatesQTvs(..),
   anyRewritableTyVar,
 
-  -- * Extracting bound variables
-  allBoundVariables, allBoundVariabless,
-
   ---------------------------------
   -- Foreign import and export
   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
@@ -132,13 +131,14 @@ module TcType (
 
   --------------------------------
   -- Rexported from Type
-  Type, PredType, ThetaType, TyBinder, ArgFlag(..),
+  Type, PredType, ThetaType, TyCoBinder, ArgFlag(..),
 
-  mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkInvForAllTy,
+  mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy,
+  mkInvForAllTy, mkInvForAllTys,
   mkFunTy, mkFunTys,
   mkTyConApp, mkAppTy, mkAppTys,
-  mkTyConTy, mkTyVarTy,
-  mkTyVarTys,
+  mkTyConTy, mkTyVarTy, mkTyVarTys,
+  mkTyCoVarTy, mkTyCoVarTys,
 
   isClassPred, isEqPred, isNomEqPred, isIPPred,
   mkClassPred,
@@ -149,7 +149,7 @@ module TcType (
 
   -- Type substitutions
   TCvSubst(..),         -- Representation visible to a few friends
-  TvSubstEnv, emptyTCvSubst,
+  TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
   zipTvSubst,
   mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,
   getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,
@@ -177,22 +177,24 @@ module TcType (
   noFreeVarsOfType,
 
   --------------------------------
-  -- Transforming Types to TcTypes
-  toTcType,    -- :: Type -> TcType
-  toTcTypeBag, -- :: Bag EvVar -> Bag EvVar
-
   pprKind, pprParendKind, pprSigmaType,
   pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
   pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
-  pprTvBndr, pprTvBndrs,
+  pprTCvBndr, pprTCvBndrs,
 
-  TypeSize, sizeType, sizeTypes, toposortTyVars
+  TypeSize, sizeType, sizeTypes, toposortTyVars,
+
+  ---------------------------------
+  -- argument visibility
+  tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible
 
   ) where
 
 #include "HsVersions.h"
 
 -- friends:
+import GhcPrelude
+
 import Kind
 import TyCoRep
 import Class
@@ -217,16 +219,18 @@ import TysWiredIn( coercibleClass, unitTyCon, unitTyConKey
                  , listTyCon, constraintKind )
 import BasicTypes
 import Util
-import Bag
 import Maybes
+import ListSetOps ( getNth, findDupsEq )
 import Outputable
 import FastString
 import ErrUtils( Validity(..), MsgDoc, isValid )
-import FV
 import qualified GHC.LanguageExtensions as LangExt
 
+import Data.List  ( mapAccumL )
+import Data.Functor.Identity( Identity(..) )
 import Data.IORef
-import Data.Functor.Identity
+import Data.List.NonEmpty( NonEmpty(..) )
+import qualified Data.Semigroup as Semi
 
 {-
 ************************************************************************
@@ -264,18 +268,23 @@ tau ::= tyvar
 -- In all cases, a (saturated) type synonym application is legal,
 -- provided it expands to the required form.
 
-Note [TcTyVars in the typechecker]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [TcTyVars and TyVars in the typechecker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The typechecker uses a lot of type variables with special properties,
 notably being a unification variable with a mutable reference.  These
 use the 'TcTyVar' variant of Var.Var.
 
-However, the type checker and constraint solver can encounter type
+Note, though, that a /bound/ type variable can (and probably should)
+be a TyVar.  E.g
+    forall a. a -> a
+Here 'a' is really just a deBruijn-number; it certainly does not have
+a signficant TcLevel (as every TcTyVar does).  So a forall-bound type
+variable should be TyVars; and hence a TyVar can appear free in a TcType.
+
+The type checker and constraint solver can also encounter /free/ type
 variables that use the 'TyVar' variant of Var.Var, for a couple of
 reasons:
 
-  - When unifying or flattening under (forall a. ty)
-
   - When typechecking a class decl, say
        class C (a :: k) where
           foo :: T a -> Int
@@ -285,8 +294,16 @@ reasons:
     solve any kind equalities in foo's signature.  So the solver
     may see free occurrences of 'k'.
 
+    See calls to tcExtendTyVarEnv for other places that ordinary
+    TyVars are bought into scope, and hence may show up in the types
+    and kinds generated by TcHsType.
+
+  - The pattern-match overlap checker calls the constraint solver,
+    long afer TcTyVars have been zonked away
+
 It's convenient to simply treat these TyVars as skolem constants,
-which of course they are.  So
+which of course they are.  We give them a level number of "outermost",
+so they behave as global constants.  Specifically:
 
 * Var.tcTyVarDetails succeeds on a TyVar, returning
   vanillaSkolemTv, as well as on a TcTyVar.
@@ -313,8 +330,7 @@ for coercion variables--on the variable. Failing to do so led to
 GHC Trac #12785.
 -}
 
--- See Note [TcTyVars in the typechecker]
-type TcTyVar = TyVar    -- Used only during type inference
+-- See Note [TcTyVars and TyVars in the typechecker]
 type TcCoVar = CoVar    -- Used only during type inference
 type TcType = Type      -- A TcType can have mutable type variables
 type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar
@@ -323,8 +339,8 @@ type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar
         -- a cannot occur inside a MutTyVar in T; that is,
         -- T is "flattened" before quantifying over a
 
-type TcTyVarBinder = TyVarBinder
-type TcTyCon       = TyCon   -- these can be the TcTyCon constructor
+type TcTyVarBinder   = TyVarBinder
+type TcTyCon         = TyCon   -- these can be the TcTyCon constructor
 
 -- These types do not have boxy type variables in them
 type TcPredType     = PredType
@@ -338,7 +354,6 @@ type TcTyCoVarSet   = TyCoVarSet
 type TcDTyVarSet    = DTyVarSet
 type TcDTyCoVarSet  = DTyCoVarSet
 
-
 {- *********************************************************************
 *                                                                      *
           ExpType: an "expected type" in the type checker
@@ -439,31 +454,23 @@ why Var.hs shouldn't actually have the definition, but it "belongs" here.
 
 Note [Signature skolems]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-A SigTv is a specialised variant of TauTv, with the following invarints:
+A TyVarTv is a specialised variant of TauTv, with the following invarints:
 
-    * A SigTv can be unified only with a TyVar,
+    * A TyVarTv can be unified only with a TyVar,
       not with any other type
 
-    * Its MetaDetails, if filled in, will always be another SigTv
+    * Its MetaDetails, if filled in, will always be another TyVarTv
       or a SkolemTv
 
-SigTvs are only distinguished to improve error messages.
+TyVarTvs are only distinguished to improve error messages.
 Consider this
 
-  f :: forall a. [a] -> Int
-  f (x::b : xs) = 3
-
-Here 'b' is a lexically scoped type variable, but it turns out to be
-the same as the skolem 'a'.  So we make them both SigTvs, which can unify
-with each other.
-
-Similarly consider
   data T (a:k1) = MkT (S a)
   data S (b:k2) = MkS (T b)
+
 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.
+because they end up unifying; we want those TyVarTvs again.
 
-SigTvs are used *only* for pattern type signatures.
 
 Note [TyVars and TcTyVars during type checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -492,6 +499,8 @@ we would need to enforce the separation.
 data TcTyVarDetails
   = SkolemTv      -- A skolem
        TcLevel    -- Level of the implication that binds it
+                  -- See TcUnify Note [Deeper level on the left] for
+                  --     how this level number is used
        Bool       -- True <=> this skolem type variable can be overlapped
                   --          when looking up instances
                   -- See Note [Binding when looking up instances] in InstEnv
@@ -505,8 +514,10 @@ data TcTyVarDetails
 
 vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
 -- See Note [Binding when looking up instances] in InstEnv
-vanillaSkolemTv = SkolemTv (pushTcLevel topTcLevel) False  -- Might be instantiated
-superSkolemTv   = SkolemTv (pushTcLevel topTcLevel) True   -- Treat this as a completely distinct type
+vanillaSkolemTv = SkolemTv topTcLevel False  -- Might be instantiated
+superSkolemTv   = SkolemTv topTcLevel True   -- Treat this as a completely distinct type
+                  -- The choice of level number here is a bit dodgy, but
+                  -- topTcLevel works in the places that vanillaSkolemTv is used
 
 -----------------------------
 data MetaDetails
@@ -518,7 +529,7 @@ data MetaInfo
                    -- A TauTv is always filled in with a tau-type, which
                    -- never contains any ForAlls.
 
-   | SigTv         -- A variant of TauTv, except that it should not be
+   | TyVarTv       -- A variant of TauTv, except that it should not be
                    --   unified with a type, only with a type variable
                    -- See Note [Signature skolems]
 
@@ -546,7 +557,7 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
   where
     pp_info = case info of
                 TauTv      -> text "tau"
-                SigTv      -> text "sig"
+                TyVarTv    -> text "tyv"
                 FlatMetaTv -> text "fmv"
                 FlatSkolTv -> text "fsk"
 
@@ -576,6 +587,7 @@ data UserTypeCtxt
 
   | InfSigCtxt Name     -- Inferred type for function
   | ExprSigCtxt         -- Expression type signature
+  | KindSigCtxt         -- Kind signature
   | TypeAppCtxt         -- Visible type application
   | ConArgCtxt Name     -- Data constructor argument
   | TySynCtxt Name      -- RHS of a type synonym decl
@@ -589,7 +601,9 @@ data UserTypeCtxt
                         --      f x :: t = ....
   | ForSigCtxt Name     -- Foreign import or export signature
   | DefaultDeclCtxt     -- Types in a default declaration
-  | InstDeclCtxt        -- An instance declaration
+  | InstDeclCtxt Bool   -- An instance declaration
+                        --    True:  stand-alone deriving
+                        --    False: vanilla instance declaration
   | SpecInstCtxt        -- SPECIALISE instance pragma
   | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
   | GenSigCtxt          -- Higher-rank or impredicative situations
@@ -602,6 +616,11 @@ data UserTypeCtxt
                         --      f :: <S> => a -> a
   | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                         --      data <S> => T a = MkT a
+  | DerivClauseCtxt     -- A 'deriving' clause
+  | TyVarBndrKindCtxt Name  -- The kind of a type variable being bound
+  | DataKindCtxt Name   -- The kind of a data/newtype (instance)
+  | TySynKindCtxt Name  -- The kind of the RHS of a type synonym
+  | TyFamResKindCtxt Name   -- The result kind of a type family
 
 {-
 -- Notes re TySynCtxt
@@ -621,6 +640,7 @@ pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (pp
 pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)
 pprUserTypeCtxt (RuleSigCtxt n)   = text "a RULE for" <+> quotes (ppr n)
 pprUserTypeCtxt ExprSigCtxt       = text "an expression type signature"
+pprUserTypeCtxt KindSigCtxt       = text "a kind signature"
 pprUserTypeCtxt TypeAppCtxt       = text "a type argument"
 pprUserTypeCtxt (ConArgCtxt c)    = text "the type of the constructor" <+> quotes (ppr c)
 pprUserTypeCtxt (TySynCtxt c)     = text "the RHS of the type synonym" <+> quotes (ppr c)
@@ -629,7 +649,8 @@ pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature"
 pprUserTypeCtxt ResSigCtxt        = text "a result type signature"
 pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n)
 pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration"
-pprUserTypeCtxt InstDeclCtxt      = text "an instance declaration"
+pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration"
+pprUserTypeCtxt (InstDeclCtxt True)  = text "a stand-alone deriving instance declaration"
 pprUserTypeCtxt SpecInstCtxt      = text "a SPECIALISE instance pragma"
 pprUserTypeCtxt GenSigCtxt        = text "a type expected by the context"
 pprUserTypeCtxt GhciCtxt          = text "a type in a GHCi command"
@@ -637,6 +658,11 @@ pprUserTypeCtxt (ClassSCCtxt c)   = text "the super-classes of class" <+> quotes
 pprUserTypeCtxt SigmaCtxt         = text "the context of a polymorphic type"
 pprUserTypeCtxt (DataTyCtxt tc)   = text "the context of the data type declaration for" <+> quotes (ppr tc)
 pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n)
+pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
+pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)
+pprUserTypeCtxt (DataKindCtxt n)  = text "the kind annotation on the declaration for" <+> quotes (ppr n)
+pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
+pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)
 
 isSigMaybe :: UserTypeCtxt -> Maybe Name
 isSigMaybe (FunSigCtxt n _) = Just n
@@ -665,25 +691,41 @@ Note [TcLevel and untouchable type variables]
 
 * INVARIANTS.  In a tree of Implications,
 
-    (ImplicInv) The level number of an Implication is
+    (ImplicInv) The level number (ic_tclvl) of an Implication is
                 STRICTLY GREATER THAN that of its parent
 
-    (MetaTvInv) The level number of a unification variable is
-                LESS THAN OR EQUAL TO that of its parent
-                implication
+    (SkolInv)   The level number of the skolems (ic_skols) of an
+                Implication is equal to the level of the implication
+                itself (ic_tclvl)
+
+    (GivenInv)  The level number of a unification variable appearing
+                in the 'ic_given' of an implication I should be
+                STRICTLY LESS THAN the ic_tclvl of I
+
+    (WantedInv) The level number of a unification variable appearing
+                in the 'ic_wanted' of an implication I should be
+                LESS THAN OR EQUAL TO the ic_tclvl of I
+                See Note [WantedInv]
 
 * A unification variable is *touchable* if its level number
-  is EQUAL TO that of its immediate parent implication.
+  is EQUAL TO that of its immediate parent implication,
+  and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv
+
+Note [WantedInv]
+~~~~~~~~~~~~~~~~
+Why is WantedInv important?  Consider this implication, where
+the constraint (C alpha[3]) disobeys WantedInv:
 
-* INVARIANT
-    (GivenInv)  The free variables of the ic_given of an
-                implication are all untouchable; ie their level
-                numbers are LESS THAN the ic_tclvl of the implication
+   forall[2] a. blah => (C alpha[3])
+                        (forall[3] b. alpha[3] ~ b)
+
+We can unify alpha:=b in the inner implication, because 'alpha' is
+touchable; but then 'b' has excaped its scope into the outer implication.
 
 Note [Skolem escape prevention]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We only unify touchable unification variables.  Because of
-(MetaTvInv), there can be no occurrences of the variable further out,
+(WantedInv), there can be no occurrences of the variable further out,
 so the unification can't cause the skolems to escape. Example:
      data T = forall a. MkT a (a->Int)
      f x (MkT v f) = length [v,x]
@@ -717,28 +759,21 @@ Note [TcLevel assignment]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 We arrange the TcLevels like this
 
-   0   Level for all flatten meta-vars
-   1   Top level
-   2   First-level implication constraints
-   3   Second-level implication constraints
+   0   Top level
+   1   First-level implication constraints
+   2   Second-level implication constraints
    ...etc...
-
-The flatten meta-vars are all at level 0, just to make them untouchable.
 -}
 
 maxTcLevel :: TcLevel -> TcLevel -> TcLevel
 maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b)
 
-fmvTcLevel :: TcLevel
--- See Note [TcLevel assignment]
-fmvTcLevel = TcLevel 0
-
 topTcLevel :: TcLevel
 -- See Note [TcLevel assignment]
-topTcLevel = TcLevel 1   -- 1 = outermost level
+topTcLevel = TcLevel 0   -- 0 = outermost level
 
 isTopTcLevel :: TcLevel -> Bool
-isTopTcLevel (TcLevel 1) = True
+isTopTcLevel (TcLevel 0) = True
 isTopTcLevel _           = False
 
 pushTcLevel :: TcLevel -> TcLevel
@@ -755,7 +790,7 @@ sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
                              --     So <= would be equivalent
 
 checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
--- Checks (MetaTvInv) from Note [TcLevel and untouchable type variables]
+-- Checks (WantedInv) from Note [TcLevel and untouchable type variables]
 checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
   = ctxt_tclvl >= tv_tclvl
 
@@ -767,6 +802,7 @@ tcTyVarLevel tv
           SkolemTv tv_lvl _             -> tv_lvl
           RuntimeUnk                    -> topTcLevel
 
+
 tcTypeLevel :: TcType -> TcLevel
 -- Max level of any free var of the type
 tcTypeLevel ty
@@ -774,11 +810,37 @@ tcTypeLevel ty
   where
     add v lvl
       | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v
-      | otherwise   = lvl
+      | otherwise = lvl
 
 instance Outputable TcLevel where
   ppr (TcLevel us) = ppr us
 
+promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
+promoteSkolem tclvl skol
+  | tclvl < tcTyVarLevel skol
+  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+    setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol))
+
+  | otherwise
+  = skol
+
+-- | Change the TcLevel in a skolem, extending a substitution
+promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
+promoteSkolemX tclvl subst skol
+  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
+    (new_subst, new_skol)
+  where
+    new_skol
+      | tclvl < tcTyVarLevel skol
+      = setTcTyVarDetails (updateTyVarKind (substTy subst) skol)
+                          (SkolemTv tclvl (isOverlappableTyVar skol))
+      | otherwise
+      = updateTyVarKind (substTy subst) skol
+    new_subst = extendTvSubstWithClone subst skol new_skol
+
+promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
+promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl)
+
 {- *********************************************************************
 *                                                                      *
     Finding type family instances
@@ -786,7 +848,7 @@ instance Outputable TcLevel where
 ************************************************************************
 -}
 
--- | Finds outermost type-family applications occuring in a type,
+-- | Finds outermost type-family applications occurring in a type,
 -- after expanding synonyms.  In the list (F, tys) that is returned
 -- we guarantee that tys matches F's arity.  For example, given
 --    type family F a :: * -> *    (arity 1)
@@ -806,7 +868,7 @@ tcTyFamInsts (TyConApp tc tys)
   | isTypeFamilyTyCon tc        = [(tc, take (tyConArity tc) tys)]
   | otherwise                   = concat (map tcTyFamInsts tys)
 tcTyFamInsts (LitTy {})         = []
-tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderKind bndr)
+tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr)
                                   ++ tcTyFamInsts ty
 tcTyFamInsts (FunTy ty1 ty2)    = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
 tcTyFamInsts (AppTy ty1 ty2)    = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
@@ -814,6 +876,10 @@ tcTyFamInsts (CastTy ty _)      = tcTyFamInsts ty
 tcTyFamInsts (CoercionTy _)     = []  -- don't count tyfams in coercions,
                                       -- as they never get normalized, anyway
 
+isTyFamFree :: Type -> Bool
+-- ^ Check that a type does not contain any type family applications.
+isTyFamFree = null . tcTyFamInsts
+
 {-
 ************************************************************************
 *                                                                      *
@@ -857,30 +923,34 @@ exactTyCoVarsOfType ty
   = go ty
   where
     go ty | Just ty' <- tcView ty = go ty'  -- This is the key line
-    go (TyVarTy tv)         = unitVarSet tv `unionVarSet` go (tyVarKind tv)
+    go (TyVarTy tv)         = goVar tv
     go (TyConApp _ tys)     = exactTyCoVarsOfTypes tys
     go (LitTy {})           = emptyVarSet
     go (AppTy fun arg)      = go fun `unionVarSet` go arg
     go (FunTy arg res)      = go arg `unionVarSet` go res
-    go (ForAllTy bndr ty)   = delBinderVar (go ty) bndr `unionVarSet` go (binderKind bndr)
+    go (ForAllTy bndr ty)   = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr)
     go (CastTy ty co)       = go ty `unionVarSet` goCo co
     go (CoercionTy co)      = goCo co
 
-    goCo (Refl _ ty)        = go ty
+    goMCo MRefl    = emptyVarSet
+    goMCo (MCo co) = goCo co
+
+    goCo (Refl ty)            = go ty
+    goCo (GRefl _ ty mco)     = go ty `unionVarSet` goMCo mco
     goCo (TyConAppCo _ _ args)= goCos args
     goCo (AppCo co arg)     = goCo co `unionVarSet` goCo arg
     goCo (ForAllCo tv k_co co)
       = goCo co `delVarSet` tv `unionVarSet` goCo k_co
     goCo (FunCo _ co1 co2)   = goCo co1 `unionVarSet` goCo co2
-    goCo (CoVarCo v)         = unitVarSet v `unionVarSet` go (varType v)
+    goCo (CoVarCo v)         = goVar v
+    goCo (HoleCo h)          = goVar (coHoleCoVar h)
     goCo (AxiomInstCo _ _ args) = goCos args
     goCo (UnivCo p _ t1 t2)  = goProv p `unionVarSet` go t1 `unionVarSet` go t2
     goCo (SymCo co)          = goCo co
     goCo (TransCo co1 co2)   = goCo co1 `unionVarSet` goCo co2
-    goCo (NthCo _ co)        = goCo co
+    goCo (NthCo _ _ co)      = goCo co
     goCo (LRCo _ co)         = goCo co
     goCo (InstCo co arg)     = goCo co `unionVarSet` goCo arg
-    goCo (CoherenceCo c1 c2) = goCo c1 `unionVarSet` goCo c2
     goCo (KindCo co)         = goCo co
     goCo (SubCo co)          = goCo co
     goCo (AxiomRuleCo _ c)   = goCos c
@@ -891,72 +961,67 @@ exactTyCoVarsOfType ty
     goProv (PhantomProv kco)    = goCo kco
     goProv (ProofIrrelProv kco) = goCo kco
     goProv (PluginProv _)       = emptyVarSet
-    goProv (HoleProv _)         = emptyVarSet
+
+    goVar v = unitVarSet v `unionVarSet` go (varType v)
 
 exactTyCoVarsOfTypes :: [Type] -> TyVarSet
 exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys
 
-anyRewritableTyVar :: Bool -> (TcTyVar -> Bool)
+anyRewritableTyVar :: Bool    -- Ignore casts and coercions
+                   -> EqRel   -- Ambient role
+                   -> (EqRel -> TcTyVar -> Bool)
                    -> TcType -> Bool
 -- (anyRewritableTyVar ignore_cos pred ty) returns True
---    if the 'pred' returns True of free TyVar in 'ty'
+--    if the 'pred' returns True of any free TyVar in 'ty'
 -- Do not look inside casts and coercions if 'ignore_cos' is True
--- See Note [anyRewritableTyVar]
-anyRewritableTyVar ignore_cos pred ty
-  = go emptyVarSet ty
+-- See Note [anyRewritableTyVar must be role-aware]
+anyRewritableTyVar ignore_cos role pred ty
+  = go role emptyVarSet ty
   where
-    go_tv bound tv | tv `elemVarSet` bound = False
-                   | otherwise             = pred tv
-
-    go bound (TyVarTy tv)     = go_tv bound tv
-    go _     (LitTy {})       = False
-    go bound (TyConApp _ tys) = any (go bound) tys
-    go bound (AppTy fun arg)  = go bound fun || go bound arg
-    go bound (FunTy arg res)  = go bound arg || go bound res
-    go bound (ForAllTy tv ty) = go (bound `extendVarSet` binderVar tv) ty
-    go bound (CastTy ty co)   = go bound ty || go_co bound co
-    go bound (CoercionTy co)  = go_co bound co
-
-    go_co bound co
+    go_tv rl bvs tv | tv `elemVarSet` bvs = False
+                    | otherwise           = pred rl tv
+
+    go rl bvs (TyVarTy tv)      = go_tv rl bvs tv
+    go _ _     (LitTy {})       = False
+    go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys
+    go rl bvs (AppTy fun arg)   = go rl bvs fun || go NomEq bvs arg
+    go rl bvs (FunTy arg res)   = go rl bvs arg || go rl bvs res
+    go rl bvs (ForAllTy tv ty)  = go rl (bvs `extendVarSet` binderVar tv) ty
+    go rl bvs (CastTy ty co)    = go rl bvs ty || go_co rl bvs co
+    go rl bvs (CoercionTy co)   = go_co rl bvs co  -- ToDo: check
+
+    go_tc NomEq  bvs _  tys = any (go NomEq bvs) tys
+    go_tc ReprEq bvs tc tys = foldr ((&&) . go_arg bvs) False $
+                              (tyConRolesRepresentational tc `zip` tys)
+
+    go_arg bvs (Nominal,          ty) = go NomEq  bvs ty
+    go_arg bvs (Representational, ty) = go ReprEq bvs ty
+    go_arg _   (Phantom,          _)  = False  -- We never rewrite with phantoms
+
+    go_co rl bvs co
       | ignore_cos = False
-      | otherwise  = anyVarSet (go_tv bound) (tyCoVarsOfCo co)
+      | otherwise  = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co)
       -- We don't have an equivalent of anyRewritableTyVar for coercions
       -- (at least not yet) so take the free vars and test them
 
-{- Note [anyRewritableTyVar]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [anyRewritableTyVar must be role-aware]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 anyRewritableTyVar is used during kick-out from the inert set,
 to decide if, given a new equality (a ~ ty), we should kick out
 a constraint C.  Rather than gather free variables and see if 'a'
 is among them, we instead pass in a predicate; this is just efficiency.
--}
 
-{- *********************************************************************
-*                                                                      *
-          Bound variables in a type
-*                                                                      *
-********************************************************************* -}
-
--- | Find all variables bound anywhere in a type.
--- See also Note [Scope-check inferred kinds] in TcHsType
-allBoundVariables :: Type -> TyVarSet
-allBoundVariables ty = fvVarSet $ go ty
-  where
-    go :: Type -> FV
-    go (TyVarTy tv)     = go (tyVarKind tv)
-    go (TyConApp _ tys) = mapUnionFV go tys
-    go (AppTy t1 t2)    = go t1 `unionFV` go t2
-    go (FunTy t1 t2)    = go t1 `unionFV` go t2
-    go (ForAllTy (TvBndr tv _) t2) = FV.unitFV tv `unionFV`
-                                    go (tyVarKind tv) `unionFV` go t2
-    go (LitTy {})       = emptyFV
-    go (CastTy ty _)    = go ty
-    go (CoercionTy {})  = emptyFV
-      -- any types mentioned in a coercion should also be mentioned in
-      -- a type.
-
-allBoundVariabless :: [Type] -> TyVarSet
-allBoundVariabless = mapUnionVarSet allBoundVariables
+Moreover, consider
+  work item:   [G] a ~R f b
+  inert item:  [G] b ~R f a
+We use anyRewritableTyVar to decide whether to kick out the inert item,
+on the grounds that the work item might rewrite it. Well, 'a' is certainly
+free in [G] b ~R f a.  But because the role of a type variable ('f' in
+this case) is nominal, the work item can't actually rewrite the inert item.
+Moreover, if we were to kick out the inert item the exact same situation
+would re-occur and we end up with an infinite loop in which each kicks
+out the other (Trac #14363).
+-}
 
 {- *********************************************************************
 *                                                                      *
@@ -974,13 +1039,15 @@ data CandidatesQTvs  -- See Note [Dependent type variables]
          -- See Note [Dependent type variables]
     }
 
-instance Monoid CandidatesQTvs where
-   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }
-   mappend (DV { dv_kvs = kv1, dv_tvs = tv1 })
-           (DV { dv_kvs = kv2, dv_tvs = tv2 })
+instance Semi.Semigroup CandidatesQTvs where
+   (DV { dv_kvs = kv1, dv_tvs = tv1 }) <> (DV { dv_kvs = kv2, dv_tvs = tv2 })
           = DV { dv_kvs = kv1 `unionDVarSet` kv2
                , dv_tvs = tv1 `unionDVarSet` tv2}
 
+instance Monoid CandidatesQTvs where
+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet }
+   mappend = (Semi.<>)
+
 instance Outputable CandidatesQTvs where
   ppr (DV {dv_kvs = kvs, dv_tvs = tvs })
     = text "DV" <+> braces (sep [ text "dv_kvs =" <+> ppr kvs
@@ -1067,7 +1134,7 @@ split_dvs bound dvs ty
   = go dvs ty
   where
     go dv (AppTy t1 t2)    = go (go dv t1) t2
-    go dv (TyConApp _ tys) = foldl go dv tys
+    go dv (TyConApp _ tys) = foldl' go dv tys
     go dv (FunTy arg res)  = go (go dv arg) res
     go dv (LitTy {})       = dv
     go dv (CastTy ty co)   = go dv ty `mappend` go_co co
@@ -1081,7 +1148,7 @@ split_dvs bound dvs ty
                       kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv))
            , dv_tvs = tvs `extendDVarSet` tv }
 
-    go dv (ForAllTy (TvBndr tv _) ty)
+    go dv (ForAllTy (Bndr tv _) ty)
       = DV { dv_kvs = kvs `unionDVarSet`
                       kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv))
            , dv_tvs = tvs }
@@ -1097,7 +1164,7 @@ split_dvs bound dvs ty
 
 -- | Like 'splitDepVarsOfType', but over a list of types
 candidateQTyVarsOfTypes :: [Type] -> CandidatesQTvs
-candidateQTyVarsOfTypes = foldl (split_dvs emptyVarSet) mempty
+candidateQTyVarsOfTypes = foldl' (split_dvs emptyVarSet) mempty
 
 {-
 ************************************************************************
@@ -1108,40 +1175,28 @@ candidateQTyVarsOfTypes = foldl (split_dvs emptyVarSet) mempty
 -}
 
 tcIsTcTyVar :: TcTyVar -> Bool
--- See Note [TcTyVars in the typechecker]
+-- See Note [TcTyVars and TyVars in the typechecker]
 tcIsTcTyVar tv = isTyVar tv
 
-isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool
-isTouchableOrFmv ctxt_tclvl tv
-  = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-      MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info }
-        -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
-                    ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
-           case info of
-             FlatMetaTv -> True
-             _          -> tv_tclvl `sameDepthAs` ctxt_tclvl
-      _          -> False
-
 isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
 isTouchableMetaTyVar ctxt_tclvl tv
   | isTyVar tv -- See Note [Coercion variables in free variable lists]
-  = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-      MetaTv { mtv_tclvl = tv_tclvl }
-        -> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
-                    ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
-           tv_tclvl `sameDepthAs` ctxt_tclvl
-      _ -> False
+  , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
+  , not (isFlattenInfo info)
+  = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
+             ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
+    tv_tclvl `sameDepthAs` ctxt_tclvl
+
   | otherwise = False
 
 isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
 isFloatedTouchableMetaTyVar ctxt_tclvl tv
   | isTyVar tv -- See Note [Coercion variables in free variable lists]
+  , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
+  , not (isFlattenInfo info)
   = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-      MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl
-      _ -> False
+    tv_tclvl `strictlyDeeperThan` ctxt_tclvl
+
   | otherwise = False
 
 isImmutableTyVar :: TyVar -> Bool
@@ -1154,12 +1209,12 @@ isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
 isTyConableTyVar tv
         -- True of a meta-type variable that can be filled in
         -- with a type constructor application; in particular,
-        -- not a SigTv
+        -- not a TyVarTv
   | isTyVar tv -- See Note [Coercion variables in free variable lists]
   = ASSERT2( tcIsTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
-        MetaTv { mtv_info = SigTv } -> False
-        _                           -> True
+        MetaTv { mtv_info = TyVarTv } -> False
+        _                             -> True
   | otherwise = True
 
 isFmvTyVar tv
@@ -1176,7 +1231,10 @@ isFskTyVar tv
 
 -- | True of both given and wanted flatten-skolems (fak and usk)
 isFlattenTyVar tv
-  = isFmvTyVar tv || isFskTyVar tv
+  = ASSERT2( tcIsTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+        MetaTv { mtv_info = info } -> isFlattenInfo info
+        _                          -> False
 
 isSkolemTyVar tv
   = ASSERT2( tcIsTcTyVar tv, ppr tv )
@@ -1223,6 +1281,11 @@ metaTyVarInfo tv
       MetaTv { mtv_info = info } -> info
       _ -> pprPanic "metaTyVarInfo" (ppr tv)
 
+isFlattenInfo :: MetaInfo -> Bool
+isFlattenInfo FlatMetaTv = True
+isFlattenInfo FlatSkolTv = True
+isFlattenInfo _          = False
+
 metaTyVarTcLevel :: TcTyVar -> TcLevel
 metaTyVarTcLevel tv
   = case tcTyVarDetails tv of
@@ -1247,11 +1310,11 @@ setMetaTyVarTcLevel tv tclvl
       details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl })
       _ -> pprPanic "metaTyVarTcLevel" (ppr tv)
 
-isSigTyVar :: Var -> Bool
-isSigTyVar tv
+isTyVarTyVar :: Var -> Bool
+isTyVarTyVar tv
   = case tcTyVarDetails tv of
-        MetaTv { mtv_info = SigTv } -> True
-        _                           -> False
+        MetaTv { mtv_info = TyVarTv } -> True
+        _                             -> False
 
 isFlexi, isIndirect :: MetaDetails -> Bool
 isFlexi Flexi = True
@@ -1266,6 +1329,20 @@ isRuntimeUnkSkol x
   | RuntimeUnk <- tcTyVarDetails x = True
   | otherwise                      = False
 
+mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)]
+-- Just pair each TyVar with its own name
+mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs]
+
+findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)]
+-- If we have [...(x1,tv)...(x2,tv)...]
+-- return (x1,x2) in the result list
+findDupTyVarTvs prs
+  = concatMap mk_result_prs $
+    findDupsEq eq_snd prs
+  where
+    eq_snd (_,tv1) (_,tv2) = tv1 == tv2
+    mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1274,18 +1351,18 @@ isRuntimeUnkSkol x
 ************************************************************************
 -}
 
-mkSigmaTy :: [TyVarBinder] -> [PredType] -> Type -> Type
+mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type
 mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau)
 
 -- | Make a sigma ty where all type variables are 'Inferred'. That is,
 -- they cannot be used with visible type application.
-mkInfSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
-mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyVarBinders Inferred tyvars) theta ty
+mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type
+mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty
 
 -- | Make a sigma ty where all type variables are "specified". That is,
 -- they can be used with visible type application
 mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
-mkSpecSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Specified tyvars) ty
+mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty
 
 mkPhiTy :: [PredType] -> Type -> Type
 mkPhiTy = mkFunTys
@@ -1307,37 +1384,106 @@ getDFunTyLitKey :: TyLit -> OccName
 getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)
 getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n)  -- hm
 
----------------
-mkNakedTyConApp :: TyCon -> [Type] -> Type
--- Builds a TyConApp
---   * without being strict in TyCon,
---   * without satisfying the invariants of TyConApp
--- A subsequent zonking will establish the invariants
--- See Note [Type-checking inside the knot] in TcHsType
-mkNakedTyConApp tc tys = TyConApp tc tys
+{- *********************************************************************
+*                                                                      *
+           Maintaining the well-kinded type invariant
+*                                                                      *
+********************************************************************* -}
+
+{- Note [The well-kinded type invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [The tcType invariant] in TcHsType.
+
+During type inference, we maintain this invariant
+
+   (INV-TK): it is legal to call 'typeKind' on any Type ty,
+             /without/ zonking ty
+
+For example, suppose
+    kappa is a unification variable
+    We have already unified kappa := Type
+      yielding    co :: Refl (Type -> Type)
+    a :: kappa
+then consider the type
+    (a Int)
+If we call typeKind on that, we'll crash, because the (un-zonked)
+kind of 'a' is just kappa, not an arrow kind.  If we zonk first
+we'd be fine, but that is too tiresome, so instead we maintain
+(INV-TK).  So we do not form (a Int); instead we form
+    (a |> co) Int
+and typeKind has no problem with that.
+
+Bottom line: we want to keep that 'co' /even though it is Refl/.
+
+Immediate consequence: during type inference we cannot use the "smart
+contructors" for types, particularly
+   mkAppTy, mkCastTy
+because they all eliminate Refl casts.  Solution: during type
+inference use the mkNakedX type formers, which do no Refl-elimination.
+E.g. mkNakedCastTy uses an actual CastTy, without optimising for
+Refl.  (NB: mkNakedCastTy is only called in two places: in tcInferApps
+and in checkExpectedResultKind.)
+
+Where does this show up in practice: apparently mainly in
+TcHsType.tcInferApps.  Suppose we are kind-checking the type (a Int),
+where (a :: kappa).  Then in tcInferApps we'll run out of binders on
+a's kind, so we'll call matchExpectedFunKind, and unify
+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)
+That evidence is actually Refl, but we must not discard the cast to
+form the result type
+   ((a::kappa) (Int::*))
+because that does not satisfy the invariant, and crashes TypeKind.  This
+caused Trac #14174 and #14520.
+
+Notes:
+
+* The Refls will be removed later, when we zonk the type.
+
+* This /also/ applies to substitution.  We must use nakedSubstTy,
+  not substTy, because the latter uses smart constructors that do
+  Refl-elimination.
+
+-}
 
+---------------
 mkNakedAppTys :: Type -> [Type] -> Type
--- See Note [Type-checking inside the knot] in TcHsType
+-- See Note [The well-kinded type invariant]
 mkNakedAppTys ty1                []   = ty1
-mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2)
-mkNakedAppTys ty1                tys2 = foldl AppTy ty1 tys2
+mkNakedAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)
+mkNakedAppTys ty1                tys2 = foldl' AppTy ty1 tys2
 
 mkNakedAppTy :: Type -> Type -> Type
--- See Note [Type-checking inside the knot] in TcHsType
+-- See Note [The well-kinded type invariant]
 mkNakedAppTy ty1 ty2 = mkNakedAppTys ty1 [ty2]
 
 mkNakedCastTy :: Type -> Coercion -> Type
--- Do simple, fast compaction; especially dealing with Refl
--- for which it's plain stupid to create a cast
--- This simple function killed off a huge number of Refl casts
--- in types, at birth.
--- Note that it's fine to do this even for a "mkNaked" function,
--- because we don't look at TyCons.  isReflCo checks if the coercion
--- is structurally Refl; it does not check for shape k ~ k.
-mkNakedCastTy ty co | isReflCo co = ty
-mkNakedCastTy (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2)
+-- Do /not/ attempt to get rid of the cast altogether,
+-- even if it is Refl: see Note [The well-kinded type invariant]
+-- Even doing (t |> co1) |> co2  --->  t |> (co1;co2)
+-- does not seem worth the bother
+--
+-- NB: zonking will get rid of these casts, because it uses mkCastTy
+--
+-- In fact the calls to mkNakedCastTy ar pretty few and far between.
 mkNakedCastTy ty co = CastTy ty co
 
+nakedSubstTy :: HasCallStack => TCvSubst -> TcType  -> TcType
+nakedSubstTy subst ty
+  | isEmptyTCvSubst subst = ty
+  | otherwise             = runIdentity                   $
+                            checkValidSubst subst [ty] [] $
+                            mapType nakedSubstMapper subst ty
+  -- Interesting idea: use StrictIdentity to avoid space leaks
+
+nakedSubstMapper :: TyCoMapper TCvSubst Identity
+nakedSubstMapper
+  = TyCoMapper { tcm_smart      = False
+               , tcm_tyvar      = \subst tv -> return (substTyVar subst tv)
+               , tcm_covar      = \subst cv -> return (substCoVar subst cv)
+               , tcm_hole       = \_ hole   -> return (HoleCo hole)
+               , tcm_tycobinder = \subst tv _ -> return (substVarBndr subst tv)
+               , tcm_tycon    = return }
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1355,21 +1501,31 @@ variables.  It's up to you to make sure this doesn't matter.
 -- | Splits a forall type into a list of 'TyBinder's and the inner type.
 -- Always succeeds, even if it returns an empty list.
 tcSplitPiTys :: Type -> ([TyBinder], Type)
-tcSplitPiTys = splitPiTys
+tcSplitPiTys ty = ASSERT( all isTyBinder (fst sty) ) sty
+  where sty = splitPiTys ty
+
+-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise
+tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
+tcSplitPiTy_maybe ty = ASSERT( isMaybeTyBinder sty ) sty
+  where sty = splitPiTy_maybe ty
+        isMaybeTyBinder (Just (t,_)) = isTyBinder t
+        isMaybeTyBinder _ = True
 
 tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)
 tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty'
-tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty)
+tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)
 tcSplitForAllTy_maybe _                = Nothing
 
 -- | Like 'tcSplitPiTys', but splits off only named binders, returning
 -- just the tycovars.
 tcSplitForAllTys :: Type -> ([TyVar], Type)
-tcSplitForAllTys = splitForAllTys
+tcSplitForAllTys ty = ASSERT( all isTyVar (fst sty) ) sty
+  where sty = splitForAllTys ty
 
 -- | Like 'tcSplitForAllTys', but splits off only named binders.
-tcSplitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type)
-tcSplitForAllTyVarBndrs = splitForAllTyVarBndrs
+tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)
+tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty
+  where sty = splitForAllVarBndrs ty
 
 -- | Is this a ForAllTy with a named binder?
 tcIsForAllTy :: Type -> Bool
@@ -1515,7 +1671,7 @@ tcSplitFunTy_maybe _                                    = Nothing
         --
         --      g = f () ()
 
-tcSplitFunTysN :: Arity                      -- N: Number of desired args
+tcSplitFunTysN :: Arity                      -- n: Number of desired args
                -> TcRhoType
                -> Either Arity               -- Number of missing arrows
                         ([TcSigmaType],      -- Arg types (always N types)
@@ -1569,14 +1725,31 @@ tcSplitAppTys ty
                    Just (ty', arg) -> go ty' (arg:args)
                    Nothing         -> (ty,args)
 
+-- | Returns the number of arguments in the given type, without
+-- looking through synonyms. This is used only for error reporting.
+-- We don't look through synonyms because of #11313.
+tcRepGetNumAppTys :: Type -> Arity
+tcRepGetNumAppTys = length . snd . repSplitAppTys
+
 -----------------------
+-- | If the type is a tyvar, possibly under a cast, returns it, along
+-- with the coercion. Thus, the co is :: kind tv ~N kind type
+tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
+tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty'
+tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co)
+tcGetCastedTyVar_maybe (TyVarTy tv)             = Just (tv, mkNomReflCo (tyVarKind tv))
+tcGetCastedTyVar_maybe _                        = Nothing
+
 tcGetTyVar_maybe :: Type -> Maybe TyVar
 tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 tcGetTyVar_maybe _              = Nothing
 
 tcGetTyVar :: String -> Type -> TyVar
-tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
+tcGetTyVar msg ty
+  = case tcGetTyVar_maybe ty of
+     Just tv -> tv
+     Nothing -> pprPanic msg (ppr ty)
 
 tcIsTyVarTy :: Type -> Bool
 tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty'
@@ -1594,7 +1767,7 @@ tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
 --     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 --
 -- Also NB splitFunTys, not tcSplitFunTys;
--- the latter  specifically stops at PredTy arguments,
+-- the latter specifically stops at PredTy arguments,
 -- and we don't want to do that here
 tcSplitDFunTy ty
   = case tcSplitForAllTys ty   of { (tvs, rho)    ->
@@ -1630,10 +1803,10 @@ tcSplitMethodTy ty
 *                                                                      *
 ********************************************************************* -}
 
-tcEqKind :: TcKind -> TcKind -> Bool
+tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool
 tcEqKind = tcEqType
 
-tcEqType :: TcType -> TcType -> Bool
+tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool
 -- tcEqType is a proper implements the same Note [Non-trivial definitional
 -- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* ==
 -- Constraint), and that is NOT what we want in the type checker!
@@ -1688,9 +1861,9 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2
     go vis _   (LitTy lit1)        (LitTy lit2)
       = check vis $ lit1 == lit2
 
-    go vis env (ForAllTy (TvBndr tv1 vis1) ty1)
-               (ForAllTy (TvBndr tv2 vis2) ty2)
-      = go (isVisibleArgFlag vis1) env (tyVarKind tv1) (tyVarKind tv2)
+    go vis env (ForAllTy (Bndr tv1 vis1) ty1)
+               (ForAllTy (Bndr tv2 vis2) ty2)
+      = go (isVisibleArgFlag vis1) env (varType tv1) (varType tv2)
           <!> go vis (rnBndr2 env tv1 tv2) ty1 ty2
           <!> check vis (vis1 == vis2)
     -- Make sure we handle all FunTy cases since falling through to the
@@ -1728,7 +1901,7 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2
        -- be oversaturated
       where
         bndrs = tyConBinders tc
-        viss  = map (isVisibleArgFlag . tyConBinderArgFlag) bndrs
+        viss  = map isVisibleTyConBinder bndrs
     tc_vis False _ = repeat False  -- if we're not in a visible context, our args
                                    -- aren't either
 
@@ -1848,7 +2021,7 @@ pickQuantifiablePreds qtvs theta
       = case classifyPredType pred of
 
           ClassPred cls tys
-            | Just {} <- isCallStackPred pred
+            | Just {} <- isCallStackPred cls tys
               -- NEVER infer a CallStack constraint
               -- Otherwise, we let the constraints bubble up to be
               -- solved from the outer context, or be defaulted when we
@@ -1866,6 +2039,7 @@ pickQuantifiablePreds qtvs theta
 
           EqPred NomEq ty1 ty2  -> quant_fun ty1 || quant_fun ty2
           IrredPred ty          -> tyCoVarsOfType ty `intersectsVarSet` qtvs
+          ForAllPred {}         -> False
 
     pick_cls_pred flex_ctxt cls tys
       = tyCoVarsOfTypes tys `intersectsVarSet` qtvs
@@ -1895,29 +2069,48 @@ pickCapturedPreds qtvs theta
 
 -- Superclasses
 
-type PredWithSCs = (PredType, [PredType])
+type PredWithSCs a = (PredType, [PredType], a)
 
-mkMinimalBySCs :: [PredType] -> [PredType]
--- Remove predicates that can be deduced from others by superclasses,
--- including duplicate predicates. The result is a subset of the input.
-mkMinimalBySCs ptys = go preds_with_scs []
+mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a]
+-- Remove predicates that
+--
+--   - are the same as another predicate
+--
+--   - can be deduced from another by superclasses,
+--
+--   - are a reflexive equality (e.g  * ~ *)
+--     (see Note [Remove redundant provided dicts] in TcPatSyn)
+--
+-- The result is a subset of the input.
+-- The 'a' is just paired up with the PredType;
+--   typically it might be a dictionary Id
+mkMinimalBySCs get_pred xs = go preds_with_scs []
  where
-   preds_with_scs :: [PredWithSCs]
-   preds_with_scs = [ (pred, pred : transSuperClasses pred)
-                    | pred <- ptys ]
-
-   go :: [PredWithSCs]   -- Work list
-      -> [PredWithSCs]   -- Accumulating result
-      -> [PredType]
-   go [] min_preds = map fst min_preds
-   go (work_item@(p,_) : work_list) min_preds
+   preds_with_scs :: [PredWithSCs a]
+   preds_with_scs = [ (pred, pred : transSuperClasses pred, x)
+                    | x <- xs
+                    , let pred = get_pred x ]
+
+   go :: [PredWithSCs a]   -- Work list
+      -> [PredWithSCs a]   -- Accumulating result
+      -> [a]
+   go [] min_preds
+     = reverse (map thdOf3 min_preds)
+       -- The 'reverse' isn't strictly necessary, but it
+       -- means that the results are returned in the same
+       -- order as the input, which is generally saner
+   go (work_item@(p,_,_) : work_list) min_preds
+     | EqPred _ t1 t2 <- classifyPredType p
+     , t1 `tcEqType` t2   -- See TcPatSyn
+                          -- Note [Remove redundant provided dicts]
+     = go work_list min_preds
      | p `in_cloud` work_list || p `in_cloud` min_preds
      = go work_list min_preds
      | otherwise
      = go work_list (work_item : min_preds)
 
-   in_cloud :: PredType -> [PredWithSCs] -> Bool
-   in_cloud p ps = or [ p `eqType` p' | (_, scs) <- ps, p' <- scs ]
+   in_cloud :: PredType -> [PredWithSCs a] -> Bool
+   in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ]
 
 transSuperClasses :: PredType -> [PredType]
 -- (transSuperClasses p) returns (p's superclasses) not including p
@@ -1952,6 +2145,41 @@ isImprovementPred ty
       EqPred ReprEq _ _  -> False
       ClassPred cls _    -> classHasFds cls
       IrredPred {}       -> True -- Might have equalities after reduction?
+      ForAllPred {}      -> False
+
+-- | Is the equality
+--        a ~r ...a....
+-- definitely insoluble or not?
+--      a ~r Maybe a      -- Definitely insoluble
+--      a ~N ...(F a)...  -- Not definitely insoluble
+--                        -- Perhaps (F a) reduces to Int
+--      a ~R ...(N a)...  -- Not definitely insoluble
+--                        -- Perhaps newtype N a = MkN Int
+-- See Note [Occurs check error] in
+-- TcCanonical for the motivation for this function.
+isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
+isInsolubleOccursCheck eq_rel tv ty
+  = go ty
+  where
+    go ty | Just ty' <- tcView ty = go ty'
+    go (TyVarTy tv') = tv == tv' || go (tyVarKind tv')
+    go (LitTy {})    = False
+    go (AppTy t1 t2) = case eq_rel of  -- See Note [AppTy and ReprEq]
+                         NomEq  -> go t1 || go t2
+                         ReprEq -> go t1
+    go (FunTy t1 t2) = go t1 || go t2
+    go (ForAllTy (Bndr tv' _) inner_ty)
+      | tv' == tv = False
+      | otherwise = go (varType tv') || go inner_ty
+    go (CastTy ty _)  = go ty   -- ToDo: what about the coercion
+    go (CoercionTy _) = False   -- ToDo: what about the coercion
+    go (TyConApp tc tys)
+      | isGenerativeTyCon tc role = any go tys
+      | otherwise                 = any go (drop (tyConArity tc) tys)
+         -- (a ~ F b a), where F has arity 1,
+         -- has an insoluble occurs check
+
+    role = eqRelRole eq_rel
 
 {- Note [Expanding superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1982,6 +2210,19 @@ Notice that
 
 See also TcTyDecls.checkClassCycles.
 
+Note [Quantifying over equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Should we quantify over an equality constraint (s ~ t)?  In general, we don't.
+Doing so may simply postpone a type error from the function definition site to
+its call site.  (At worst, imagine (Int ~ Bool)).
+
+However, consider this
+         forall a. (F [a] ~ Int) => blah
+Should we quantify over the (F [a] ~ Int)?  Perhaps yes, because at the call
+site we will know 'a', and perhaps we have instance  F [Bool] = Int.
+So we *do* quantify over a type-family equality where the arguments mention
+the quantified variables.
+
 Note [Inheriting implicit parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this:
@@ -2024,7 +2265,7 @@ the quantified variables.
 
 ************************************************************************
 *                                                                      *
-\subsection{Predicates}
+      Classifying types
 *                                                                      *
 ************************************************************************
 -}
@@ -2091,68 +2332,53 @@ isCallStackTy ty
 -- | Is a 'PredType' a 'CallStack' implicit parameter?
 --
 -- If so, return the name of the parameter.
-isCallStackPred :: PredType -> Maybe FastString
-isCallStackPred pred
-  | Just (str, ty) <- isIPPred_maybe pred
-  , isCallStackTy ty
-  = Just str
+isCallStackPred :: Class -> [Type] -> Maybe FastString
+isCallStackPred cls tys
+  | [ty1, ty2] <- tys
+  , isIPClass cls
+  , isCallStackTy ty2
+  = isStrLitTy ty1
   | otherwise
   = Nothing
 
+hasIPPred :: PredType -> Bool
+hasIPPred pred
+  = case classifyPredType pred of
+      ClassPred cls tys
+        | isIPClass     cls -> True
+        | isCTupleClass cls -> any hasIPPred tys
+      _other -> False
+
 is_tc :: Unique -> Type -> Bool
 -- Newtypes are opaque to this
 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
                         Just (tc, _) -> uniq == getUnique tc
                         Nothing      -> False
 
--- | Does the given tyvar appear in the given type outside of any
--- non-newtypes? Assume we're looking for @a@. Says "yes" for
--- @a@, @N a@, @b a@, @a b@, @b (N a)@. Says "no" for
--- @[a]@, @Maybe a@, @T a@, where @N@ is a newtype and @T@ is a datatype.
-isTyVarExposed :: TcTyVar -> TcType -> Bool
-isTyVarExposed tv (TyVarTy tv')   = tv == tv'
-isTyVarExposed tv (TyConApp tc tys)
-  | isNewTyCon tc                 = any (isTyVarExposed tv) tys
-  | otherwise                     = False
-isTyVarExposed _  (LitTy {})      = False
-isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun
-                                 || isTyVarExposed tv arg
-isTyVarExposed _  (ForAllTy {})   = False
-isTyVarExposed _  (FunTy {})      = False
-isTyVarExposed tv (CastTy ty _)   = isTyVarExposed tv ty
-isTyVarExposed _  (CoercionTy {}) = False
-
--- | Is the equality
---        a ~r ...a....
--- definitely insoluble or not?
---      a ~r Maybe a      -- Definitely insoluble
---      a ~N ...(F a)...  -- Not definitely insoluble
---                        -- Perhaps (F a) reduces to Int
---      a ~R ...(N a)...  -- Not definitely insoluble
---                        -- Perhaps newtype N a = MkN Int
--- See Note [Occurs check error] in
--- TcCanonical for the motivation for this function.
-isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
-isInsolubleOccursCheck eq_rel tv ty
-  = go ty
-  where
-    go ty | Just ty' <- tcView ty = go ty'
-    go (TyVarTy tv') = tv == tv' || go (tyVarKind tv')
-    go (LitTy {})    = False
-    go (AppTy t1 t2) = go t1 || go t2
-    go (FunTy t1 t2) = go t1 || go t2
-    go (ForAllTy (TvBndr tv' _) inner_ty)
-      | tv' == tv = False
-      | otherwise = go (tyVarKind tv') || go inner_ty
-    go (CastTy ty _)  = go ty   -- ToDo: what about the coercion
-    go (CoercionTy _) = False   -- ToDo: what about the coercion
-    go (TyConApp tc tys)
-      | isGenerativeTyCon tc role = any go tys
-      | otherwise                 = any go (drop (tyConArity tc) tys)
-         -- (a ~ F b a), where F has arity 1,
-         -- has an insoluble occurs check
-
-    role = eqRelRole eq_rel
+-- | Does the given tyvar appear at the head of a chain of applications
+--     (a t1 ... tn)
+isTyVarHead :: TcTyVar -> TcType -> Bool
+isTyVarHead tv (TyVarTy tv')   = tv == tv'
+isTyVarHead tv (AppTy fun _)   = isTyVarHead tv fun
+isTyVarHead tv (CastTy ty _)   = isTyVarHead tv ty
+isTyVarHead _ (TyConApp {})    = False
+isTyVarHead _  (LitTy {})      = False
+isTyVarHead _  (ForAllTy {})   = False
+isTyVarHead _  (FunTy {})      = False
+isTyVarHead _  (CoercionTy {}) = False
+
+
+{- Note [AppTy and ReprEq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   a ~R# b a
+           a ~R# a b
+
+The former is /not/ a definite error; we might instantiate 'b' with Id
+   newtype Id a = MkId a
+but the latter /is/ a definite error.
+
+On the other hand, with nominal equality, both are definite errors
+-}
 
 isRigidTy :: TcType -> Bool
 isRigidTy ty
@@ -2161,73 +2387,6 @@ isRigidTy ty
   | isForAllTy ty                           = True
   | otherwise                               = False
 
-isRigidEqPred :: TcLevel -> PredTree -> Bool
--- ^ True of all Nominal equalities that are solidly insoluble
--- This means all equalities *except*
---   * Meta-tv non-SigTv on LHS
---   * Meta-tv SigTv on LHS, tyvar on right
-isRigidEqPred tc_lvl (EqPred NomEq ty1 _)
-  | Just tv1 <- tcGetTyVar_maybe ty1
-  = ASSERT2( tcIsTcTyVar tv1, ppr tv1 )
-    not (isMetaTyVar tv1) || isTouchableMetaTyVar tc_lvl tv1
-
-  | otherwise  -- LHS is not a tyvar
-  = True
-
-isRigidEqPred _ _ = False  -- Not an equality
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Transformation of Types to TcTypes}
-*                                                                      *
-************************************************************************
--}
-
-toTcType :: Type -> TcType
--- The constraint solver expects EvVars to have TcType, in which the
--- free type variables are TcTyVars. So we convert from Type to TcType here
--- A bit tiresome; but one day I expect the two types to be entirely separate
--- in which case we'll definitely need to do this
-toTcType = runIdentity . to_tc_type emptyVarSet
-
-toTcTypeBag :: Bag EvVar -> Bag EvVar -- All TyVars are transformed to TcTyVars
-toTcTypeBag evvars = mapBag (\tv -> setTyVarKind tv (toTcType (tyVarKind tv))) evvars
-
-to_tc_mapper :: TyCoMapper VarSet Identity
-to_tc_mapper
-  = TyCoMapper { tcm_smart    = False   -- more efficient not to use smart ctors
-               , tcm_tyvar    = tyvar
-               , tcm_covar    = covar
-               , tcm_hole     = hole
-               , tcm_tybinder = tybinder }
-  where
-    tyvar :: VarSet -> TyVar -> Identity Type
-    tyvar ftvs tv
-      | Just var <- lookupVarSet ftvs tv = return $ TyVarTy var
-      | isTcTyVar tv = TyVarTy <$> updateTyVarKindM (to_tc_type ftvs) tv
-      | otherwise
-      = do { kind' <- to_tc_type ftvs (tyVarKind tv)
-           ; return $ TyVarTy $ mkTcTyVar (tyVarName tv) kind' vanillaSkolemTv }
-
-    covar :: VarSet -> CoVar -> Identity Coercion
-    covar ftvs cv
-      | Just var <- lookupVarSet ftvs cv = return $ CoVarCo var
-      | otherwise = CoVarCo <$> updateVarTypeM (to_tc_type ftvs) cv
-
-    hole :: VarSet -> CoercionHole -> Role -> Type -> Type
-         -> Identity Coercion
-    hole ftvs h r t1 t2 = mkHoleCo h r <$> to_tc_type ftvs t1
-                                       <*> to_tc_type ftvs t2
-
-    tybinder :: VarSet -> TyVar -> ArgFlag -> Identity (VarSet, TyVar)
-    tybinder ftvs tv _vis = do { kind' <- to_tc_type ftvs (tyVarKind tv)
-                               ; let tv' = mkTcTyVar (tyVarName tv) kind'
-                                                     vanillaSkolemTv
-                               ; return (ftvs `extendVarSet` tv', tv') }
-
-to_tc_type :: VarSet -> Type -> Identity TcType
-to_tc_type = mapType to_tc_mapper
 
 {-
 ************************************************************************
@@ -2559,12 +2718,15 @@ sizeType = go
     go (TyVarTy {})              = 1
     go (TyConApp tc tys)
       | isTypeFamilyTyCon tc     = infinity  -- Type-family applications can
-                                           -- expand to any arbitrary size
+                                             -- expand to any arbitrary size
       | otherwise                = sizeTypes (filterOutInvisibleTypes tc tys) + 1
+                                   -- Why filter out invisible args?  I suppose any
+                                   -- size ordering is sound, but why is this better?
+                                   -- I came across this when investigating #14010.
     go (LitTy {})                = 1
     go (FunTy arg res)           = go arg + go res + 1
     go (AppTy fun arg)           = go fun + go arg
-    go (ForAllTy (TvBndr tv vis) ty)
+    go (ForAllTy (Bndr tv vis) ty)
         | isVisibleArgFlag vis   = go (tyVarKind tv) + go ty + 1
         | otherwise              = go ty + 1
     go (CastTy ty _)             = go ty
@@ -2572,3 +2734,28 @@ sizeType = go
 
 sizeTypes :: [Type] -> TypeSize
 sizeTypes tys = sum (map sizeType tys)
+
+-----------------------------------------------------------------------------------
+-----------------------------------------------------------------------------------
+-----------------------
+-- | For every arg a tycon can take, the returned list says True if the argument
+-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to
+-- allow for oversaturation.
+tcTyConVisibilities :: TyCon -> [Bool]
+tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True
+  where
+    tc_binder_viss      = map isVisibleTyConBinder (tyConBinders tc)
+    tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc))
+
+-- | If the tycon is applied to the types, is the next argument visible?
+isNextTyConArgVisible :: TyCon -> [Type] -> Bool
+isNextTyConArgVisible tc tys
+  = tcTyConVisibilities tc `getNth` length tys
+
+-- | Should this type be applied to a visible argument?
+isNextArgVisible :: TcType -> Bool
+isNextArgVisible ty
+  | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr
+  | otherwise                              = True
+    -- this second case might happen if, say, we have an unzonked TauTv.
+    -- But TauTvs can't range over types that take invisible arguments
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 6af486caaa..24e12cd15c 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -5,16 +5,24 @@ module TcTypeNats
   , typeNatCoAxiomRules
   , BuiltInSynFamily(..)
 
+    -- If you define a new built-in type family, make sure to export its TyCon
+    -- from here as well.
+    -- See Note [Adding built-in type families]
   , typeNatAddTyCon
   , typeNatMulTyCon
   , typeNatExpTyCon
   , typeNatLeqTyCon
   , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
   , typeNatCmpTyCon
   , typeSymbolCmpTyCon
   , typeSymbolAppendTyCon
   ) where
 
+import GhcPrelude
+
 import Type
 import Pair
 import TcType     ( TcType, tcEqType )
@@ -33,6 +41,9 @@ import PrelNames  ( gHC_TYPELITS
                   , typeNatExpTyFamNameKey
                   , typeNatLeqTyFamNameKey
                   , typeNatSubTyFamNameKey
+                  , typeNatDivTyFamNameKey
+                  , typeNatModTyFamNameKey
+                  , typeNatLogTyFamNameKey
                   , typeNatCmpTyFamNameKey
                   , typeSymbolCmpTyFamNameKey
                   , typeSymbolAppendFamNameKey
@@ -42,12 +53,89 @@ import FastString ( FastString
                   )
 import qualified Data.Map as Map
 import Data.Maybe ( isJust )
+import Control.Monad ( guard )
 import Data.List  ( isPrefixOf, isSuffixOf )
 
+{-
+Note [Type-level literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are currently two forms of type-level literals: natural numbers, and
+symbols (even though this module is named TcTypeNats, it covers both).
+
+Type-level literals are supported by CoAxiomRules (conditional axioms), which
+power the built-in type families (see Note [Adding built-in type families]).
+Currently, all built-in type families are for the express purpose of supporting
+type-level literals.
+
+See also the Wiki page:
+
+    https://ghc.haskell.org/trac/ghc/wiki/TypeNats
+
+Note [Adding built-in type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are a few steps to adding a built-in type family:
+
+* Adding a unique for the type family TyCon
+
+  These go in PrelNames. It will likely be of the form
+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that
+  has not been chosen before in PrelNames. There are several examples already
+  in PrelNames—see, for instance, typeNatAddTyFamNameKey.
+
+* Adding the type family TyCon itself
+
+  This goes in TcTypeNats. There are plenty of examples of how to define
+  these—see, for instance, typeNatAddTyCon.
+
+  Once your TyCon has been defined, be sure to:
+
+  - Export it from TcTypeNats. (Not doing so caused #14632.)
+  - Include it in the typeNatTyCons list, defined in TcTypeNats.
+
+* Exposing associated type family axioms
+
+  When defining the type family TyCon, you will need to define an axiom for
+  the type family in general (see, for instance, axAddDef), and perhaps other
+  auxiliary axioms for special cases of the type family (see, for instance,
+  axAdd0L and axAdd0R).
+
+  After you have defined all of these axioms, be sure to include them in the
+  typeNatCoAxiomRules list, defined in TcTypeNats.
+  (Not doing so caused #14934.)
+
+* Define the type family somewhere
+
+  Finally, you will need to define the type family somewhere, likely in @base@.
+  Currently, all of the built-in type families are defined in GHC.TypeLits or
+  GHC.TypeNats, so those are likely candidates.
+
+  Since the behavior of your built-in type family is specified in TcTypeNats,
+  you should give an open type family definition with no instances, like so:
+
+    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat
+
+  Changing the argument and result kinds as appropriate.
+
+* Update the relevant test cases
+
+  The GHC test suite will likely need to be updated after you add your built-in
+  type family. For instance:
+
+  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added
+    a test there, the expected output of T9181 will need to change.
+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit
+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have
+    runtime unit tests. Consider adding further unit tests to those if your
+    built-in type family deals with Nats or Symbols, respectively.
+-}
+
 {-------------------------------------------------------------------------------
 Built-in type constructors for functions on type-level nats
 -}
 
+-- The list of built-in type family TyCons that GHC uses.
+-- If you define a built-in type family, make sure to add it to this list.
+-- See Note [Adding built-in type families]
 typeNatTyCons :: [TyCon]
 typeNatTyCons =
   [ typeNatAddTyCon
@@ -55,6 +143,9 @@ typeNatTyCons =
   , typeNatExpTyCon
   , typeNatLeqTyCon
   , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
   , typeNatCmpTyCon
   , typeSymbolCmpTyCon
   , typeSymbolAppendTyCon
@@ -93,6 +184,32 @@ typeNatMulTyCon = mkTypeNatFunTyCon2 name
   name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")
             typeNatMulTyFamNameKey typeNatMulTyCon
 
+typeNatDivTyCon :: TyCon
+typeNatDivTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamDiv
+    , sfInteractTop   = interactTopDiv
+    , sfInteractInert = interactInertDiv
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")
+            typeNatDivTyFamNameKey typeNatDivTyCon
+
+typeNatModTyCon :: TyCon
+typeNatModTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamMod
+    , sfInteractTop   = interactTopMod
+    , sfInteractInert = interactInertMod
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")
+            typeNatModTyFamNameKey typeNatModTyCon
+
+
+
+
+
 typeNatExpTyCon :: TyCon
 typeNatExpTyCon = mkTypeNatFunTyCon2 name
   BuiltInSynFamily
@@ -104,6 +221,19 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name
   name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")
                 typeNatExpTyFamNameKey typeNatExpTyCon
 
+typeNatLogTyCon :: TyCon
+typeNatLogTyCon = mkTypeNatFunTyCon1 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamLog
+    , sfInteractTop   = interactTopLog
+    , sfInteractInert = interactInertLog
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")
+            typeNatLogTyFamNameKey typeNatLogTyCon
+
+
+
 typeNatLeqTyCon :: TyCon
 typeNatLeqTyCon =
   mkFamilyTyCon name
@@ -174,6 +304,17 @@ typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name
 
 
 
+-- Make a unary built-in constructor of kind: Nat -> Nat
+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeNatFunTyCon1 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeNatKind ])
+    typeNatKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
 
 -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
 mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
@@ -204,6 +345,7 @@ Built-in rules axioms
 
 -- If you add additional rules, please remember to add them to
 -- `typeNatCoAxiomRules` also.
+-- See Note [Adding built-in type families]
 axAddDef
   , axMulDef
   , axExpDef
@@ -228,6 +370,11 @@ axAddDef
   , axSub0R
   , axAppendSymbol0R
   , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
   :: CoAxiomRule
 
 axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $
@@ -272,6 +419,18 @@ axAppendSymbolDef = CoAxiomRule
 axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $
               \x y -> fmap num (minus x y)
 
+axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (div x y))
+
+axModDef = mkBinAxiom "ModDef" typeNatModTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (mod x y))
+
+axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $
+              \x -> do (a,_) <- genLog x 2
+                       return (num a)
+
 axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t
 axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t
 axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t
@@ -279,6 +438,9 @@ axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0
 axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0
 axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t
 axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t
+axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)
+axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)
+                                    -- XXX: Shouldn't we check that _ is 0?
 axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1
 axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1
 axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t
@@ -293,6 +455,9 @@ axAppendSymbol0R  = mkAxiom1 "Concat0R"
 axAppendSymbol0L  = mkAxiom1 "Concat0L"
             $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t
 
+-- The list of built-in type family axioms that GHC uses.
+-- If you define new axioms, make sure to include them in this list.
+-- See Note [Adding built-in type families]
 typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule
 typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))
   [ axAddDef
@@ -316,8 +481,14 @@ typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))
   , axCmpSymbolRefl
   , axLeq0L
   , axSubDef
+  , axSub0R
   , axAppendSymbol0R
   , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
   ]
 
 
@@ -335,6 +506,12 @@ s .-. t = mkTyConApp typeNatSubTyCon [s,t]
 (.*.) :: Type -> Type -> Type
 s .*. t = mkTyConApp typeNatMulTyCon [s,t]
 
+tDiv :: Type -> Type -> Type
+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]
+
+tMod :: Type -> Type -> Type
+tMod s t = mkTyConApp typeNatModTyCon [s,t]
+
 (.^.) :: Type -> Type -> Type
 s .^. t = mkTyConApp typeNatExpTyCon [s,t]
 
@@ -393,6 +570,19 @@ known p x = case isNumLitTy x of
               Nothing -> False
 
 
+mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule
+mkUnAxiom str tc f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2] <- return cs
+           s2' <- isNumLitTy s2
+           z   <- f s2'
+           return (mkTyConApp tc [s1] === z)
+    }
+
 
 
 -- For the definitional axioms
@@ -459,6 +649,24 @@ matchFamMul [s,t]
         mbY = isNumLitTy t
 matchFamMul _ = Nothing
 
+matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamDiv [s,t]
+  | Just 1 <- mbY = Just (axDiv1, [s], s)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamDiv _ = Nothing
+
+matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamMod [s,t]
+  | Just 1 <- mbY = Just (axMod1, [s], num 0)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamMod _ = Nothing
+
+
+
 matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
 matchFamExp [s,t]
   | Just 0 <- mbY = Just (axExp0R, [s], num 1)
@@ -470,6 +678,13 @@ matchFamExp [s,t]
         mbY = isNumLitTy t
 matchFamExp _ = Nothing
 
+matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamLog [s]
+  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)
+  where mbX = isNumLitTy s
+matchFamLog _ = Nothing
+
+
 matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
 matchFamLeq [s,t]
   | Just 0 <- mbX = Just (axLeq0L, [t], bool True)
@@ -577,6 +792,12 @@ interactTopMul [s,t] r
   mbZ = isNumLitTy r
 interactTopMul _ _ = []
 
+interactTopDiv :: [Xi] -> Xi -> [Pair Type]
+interactTopDiv _ _ = []   -- I can't think of anything...
+
+interactTopMod :: [Xi] -> Xi -> [Pair Type]
+interactTopMod _ _ = []   -- I can't think of anything...
+
 interactTopExp :: [Xi] -> Xi -> [Pair Type]
 interactTopExp [s,t] r
   | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)
@@ -588,6 +809,11 @@ interactTopExp [s,t] r
   mbZ = isNumLitTy r
 interactTopExp _ _ = []
 
+interactTopLog :: [Xi] -> Xi -> [Pair Type]
+interactTopLog _ _ = []   -- I can't think of anything...
+
+
+
 interactTopLeq :: [Xi] -> Xi -> [Pair Type]
 interactTopLeq [s,t] r
   | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)
@@ -653,6 +879,12 @@ interactInertMul [x1,y1] z1 [x2,y2] z2
 
 interactInertMul _ _ _ _ = []
 
+interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertDiv _ _ _ _ = []
+
+interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertMod _ _ _ _ = []
+
 interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
 interactInertExp [x1,y1] z1 [x2,y2] z2
   | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]
@@ -661,6 +893,9 @@ interactInertExp [x1,y1] z1 [x2,y2] z2
 
 interactInertExp _ _ _ _ = []
 
+interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertLog _ _ _ _ = []
+
 
 interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
 interactInertLeq [x1,y1] z1 [x2,y2] z2
@@ -714,7 +949,7 @@ rootExact x y = do (z,True) <- genRoot x y
 
 
 
-{- | Compute the the n-th root of a natural number, rounded down to
+{- | Compute the n-th root of a natural number, rounded down to
 the closest natural number.  The boolean indicates if the result
 is exact (i.e., True means no rounding was done, False means rounded down).
 The second argument specifies which root we are computing. -}
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index 2fcca7ffc2..05d49ae39d 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -10,7 +10,9 @@
 module TcTypeable(mkTypeableBinds) where
 
 
-import BasicTypes ( Boxity(..), neverInlinePragma )
+import GhcPrelude
+
+import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
 import TcBinds( addTypecheckedBinds )
 import IfaceEnv( newGlobalBinder )
 import TyCoRep( Type(..), TyLit(..) )
@@ -34,8 +36,8 @@ import Module
 import HsSyn
 import DynFlags
 import Bag
-import Var ( TyVarBndr(..) )
-import TrieMap
+import Var ( VarBndr(..) )
+import CoreMap
 import Constants
 import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
 import Outputable
@@ -343,9 +345,8 @@ mkPrimTypeableTodos
 -- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
 ghcPrimTypeableTyCons :: [TyCon]
 ghcPrimTypeableTyCons = concat
-    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon
-      , funTyCon, tupleTyCon Unboxed 0 ]
-    , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE]
+    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
     , map sumTyCon [2..mAX_SUM_SIZE]
     , primTyCons
     ]
@@ -400,7 +401,7 @@ mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
                 -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
 mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
   = do -- Make a KindRep
-       let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon)
+       let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)
        liftTc $ traceTc "mkTyConKindRepBinds"
                         (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
        let ctx = mkDeBruijnContext (map binderVar bndrs)
@@ -578,7 +579,7 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
       | otherwise
       = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
 
-    new_kind_rep (ForAllTy (TvBndr var _) ty)
+    new_kind_rep (ForAllTy (Bndr var _) ty)
       = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
 
     new_kind_rep (FunTy t1 t2)
@@ -630,12 +631,12 @@ mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
                                                    ]
 
     int :: Int -> HsLit GhcTc
-    int n = HsIntPrim (sourceText $ show n) (toInteger n)
+    int n = HsIntPrim (SourceText $ show n) (toInteger n)
 
 word64 :: DynFlags -> Word64 -> HsLit GhcTc
 word64 dflags n
-  | wORD_SIZE dflags == 4 = HsWord64Prim noSourceText (toInteger n)
-  | otherwise             = HsWordPrim   noSourceText (toInteger n)
+  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
+  | otherwise             = HsWordPrim   NoSourceText (toInteger n)
 
 {-
 Note [Representing TyCon kinds: KindRep]
@@ -653,17 +654,20 @@ The TypeRep encoding of `Proxy Type Int` looks like this:
 
     $tcProxy :: GHC.Types.TyCon
     $trInt   :: TypeRep Int
-    $trType  :: TypeRep Type
+    TrType   :: TypeRep Type
 
     $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
     $trProxyType = TrTyCon $tcProxy
-                           [$trType]  -- kind variable instantiation
+                           [TrType]  -- kind variable instantiation
+                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
+                                                         -- Type -> Type
 
     $trProxy :: TypeRep (Proxy Type Int)
-    $trProxy = TrApp $trProxyType $trInt
+    $trProxy = TrApp $trProxyType $trInt TrType
 
     $tkProxy :: GHC.Types.KindRep
-    $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
+    $tkProxy = KindRepFun (KindRepVar 0)
+                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])
 
 Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
 polymorphic types.  So instead
@@ -677,9 +681,10 @@ polymorphic types.  So instead
        Proxy :: forall k. k->Type
 
  * A KindRep is just a recipe that we can instantiate with the
-   argument kinds, using Data.Typeable.Internal.instantiateKindRep.
+   argument kinds, using Data.Typeable.Internal.tyConKind and
+   store in the relevant 'TypeRep' constructor.
 
-   Data.Typeable.Internal.typeRepKind uses instantiateKindRep
+   Data.Typeable.Internal.typeRepKind looks up the stored kinds.
 
  * In a KindRep, the kind variables are represented by 0-indexed
    de Bruijn numbers:
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 1cbf5741b2..05a30fdf35 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -13,10 +13,11 @@ module TcUnify (
   tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,
   tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,
   tcSubTypeDS_NC_O, tcSubTypeET,
-  checkConstraints, buildImplicationFor,
+  checkConstraints, checkTvConstraints,
+  buildImplicationFor,
 
   -- Various unifications
-  unifyType, unifyTheta, unifyKind, noThing,
+  unifyType, unifyKind,
   uType, promoteTcType,
   swapOverTyVars, canSolveByUnification,
 
@@ -24,22 +25,20 @@ module TcUnify (
   -- Holes
   tcInferInst, tcInferNoInst,
   matchExpectedListTy,
-  matchExpectedPArrTy,
   matchExpectedTyConApp,
   matchExpectedAppTy,
   matchExpectedFunTys,
   matchActualFunTys, matchActualFunTysPart,
   matchExpectedFunKind,
 
-  wrapFunResCoercion,
-
-  occCheckExpand, metaTyVarUpdateOK,
-  occCheckForErrors, OccCheckResult(..)
+  metaTyVarUpdateOK, occCheckForErrors, OccCheckResult(..)
 
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import HsSyn
 import TyCoRep
 import TcMType
@@ -48,7 +47,7 @@ import TcType
 import Type
 import Coercion
 import TcEvidence
-import Name ( isSystemName )
+import Name( isSystemName )
 import Inst
 import TyCon
 import TysWiredIn
@@ -61,10 +60,8 @@ import DynFlags
 import BasicTypes
 import Bag
 import Util
-import Pair( pFst )
 import qualified GHC.LanguageExtensions as LangExt
 import Outputable
-import FastString
 
 import Control.Monad
 import Control.Arrow ( second )
@@ -98,6 +95,23 @@ This is used to construct a message of form
    The function 'f' is applied to two arguments
    but its type `Int -> Int' has only one
 
+When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the
+picture, we have a choice in deciding whether to count the type applications as
+proper arguments:
+
+   The function 'f' is applied to one visible type argument
+     and two value arguments
+   but its type `forall a. a -> a` has only one visible type argument
+     and one value argument
+
+Or whether to include the type applications as part of the herald itself:
+
+   The expression 'f @Int' is applied to two arguments
+   but its type `Int -> Int` has only one
+
+The latter is easier to implement and is arguably easier to understand, so we
+choose to implement that option.
+
 Note [matchExpectedFunTys]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 matchExpectedFunTys checks that a sigma has the form
@@ -201,10 +215,9 @@ matchExpectedFunTys herald arity orig_ty thing_inside
 
 -- Like 'matchExpectedFunTys', but used when you have an "actual" type,
 -- for example in function application
-matchActualFunTys :: Outputable a
-                  => SDoc   -- See Note [Herald for matchExpectedFunTys]
+matchActualFunTys :: SDoc   -- See Note [Herald for matchExpectedFunTys]
                   -> CtOrigin
-                  -> Maybe a   -- the thing with type TcSigmaType
+                  -> Maybe (HsExpr GhcRn)   -- the thing with type TcSigmaType
                   -> Arity
                   -> TcSigmaType
                   -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
@@ -215,10 +228,9 @@ matchActualFunTys herald ct_orig mb_thing arity ty
 
 -- | Variant of 'matchActualFunTys' that works when supplied only part
 -- (that is, to the right of some arrows) of the full function type
-matchActualFunTysPart :: Outputable a
-                      => SDoc -- See Note [Herald for matchExpectedFunTys]
+matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]
                       -> CtOrigin
-                      -> Maybe a  -- the thing with type TcSigmaType
+                      -> Maybe (HsExpr GhcRn)  -- the thing with type TcSigmaType
                       -> Arity
                       -> TcSigmaType
                       -> [TcSigmaType] -- reversed args. See (*) below.
@@ -347,13 +359,6 @@ matchExpectedListTy exp_ty
  = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
       ; return (co, elt_ty) }
 
-----------------------
-matchExpectedPArrTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)
--- Special case for parrs
-matchExpectedPArrTy exp_ty
-  = do { (co, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty
-       ; return (co, elt_ty) }
-
 ---------------------
 matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
                       -> TcRhoType            -- orig_ty
@@ -391,7 +396,7 @@ matchExpectedTyConApp tc orig_ty
     -- kind-compatible with T.  For example, suppose we have
     --       matchExpectedTyConApp T (f Maybe)
     -- where data T a = MkT a
-    -- Then we don't want to instantate T's data constructors with
+    -- Then we don't want to instantiate T's data constructors with
     --    (a::*) ~ Maybe
     -- because that'll make types that are utterly ill-kinded.
     -- This happened in Trac #7368
@@ -400,7 +405,7 @@ matchExpectedTyConApp tc orig_ty
            ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)
            ; let args = mkTyVarTys arg_tvs
                  tc_template = mkTyConApp tc args
-           ; co <- unifyType noThing tc_template orig_ty
+           ; co <- unifyType Nothing tc_template orig_ty
            ; return (co, args) }
 
 ----------------------
@@ -432,7 +437,7 @@ matchExpectedAppTy orig_ty
     defer
       = do { ty1 <- newFlexiTyVarTy kind1
            ; ty2 <- newFlexiTyVarTy kind2
-           ; co <- unifyType noThing (mkAppTy ty1 ty2) orig_ty
+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty
            ; return (co, (ty1, ty2)) }
 
     orig_kind = typeKind orig_ty
@@ -531,9 +536,8 @@ skolemising the type.
 
 -- | Call this variant when you are in a higher-rank situation and
 -- you know the right-hand type is deeply skolemised.
-tcSubTypeHR :: Outputable a
-            => CtOrigin    -- ^ of the actual type
-            -> Maybe a     -- ^ If present, it has type ty_actual
+tcSubTypeHR :: CtOrigin               -- ^ of the actual type
+            -> Maybe (HsExpr GhcRn)   -- ^ If present, it has type ty_actual
             -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
 tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt
 
@@ -547,11 +551,18 @@ tcSubTypeET orig ctxt (Check ty_actual) ty_expected
   where
     eq_orig = TypeEqOrigin { uo_actual   = ty_expected
                            , uo_expected = ty_actual
-                           , uo_thing    = Nothing }
+                           , uo_thing    = Nothing
+                           , uo_visible  = True }
 
 tcSubTypeET _ _ (Infer inf_res) ty_expected
   = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )
-    do { co <- fillInferResult ty_expected inf_res
+      -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never
+      -- has the ir_inst field set.  Reason: in patterns (which is what
+      -- tcSubTypeET is used for) do not aggressively instantiate
+    do { co <- fill_infer_result ty_expected inf_res
+               -- Since ir_inst is false, we can skip fillInferResult
+               -- and go straight to fill_infer_result
+
        ; return (mkWpCastN (mkTcSymCo co)) }
 
 ------------------------
@@ -566,7 +577,7 @@ tcSubTypeO orig ctxt ty_actual ty_expected
                                        , pprUserTypeCtxt ctxt
                                        , ppr ty_actual
                                        , ppr ty_expected ])
-       ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected }
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
 
 addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a
 addSubTypeCtxt ty_actual ty_expected thing_inside
@@ -605,7 +616,8 @@ tcSubType_NC ctxt ty_actual ty_expected
   where
     origin = TypeEqOrigin { uo_actual   = ty_actual
                           , uo_expected = ty_expected
-                          , uo_thing    = Nothing }
+                          , uo_thing    = Nothing
+                          , uo_visible  = True }
 
 tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
 -- Just like tcSubType, but with the additional precondition that
@@ -613,22 +625,22 @@ tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWr
 tcSubTypeDS orig ctxt ty_actual ty_expected
   = addSubTypeCtxt ty_actual ty_expected $
     do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
-       ; tcSubTypeDS_NC_O orig ctxt noThing ty_actual ty_expected }
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
 
-tcSubTypeDS_NC_O :: Outputable a
-                 => CtOrigin   -- origin used for instantiation only
+tcSubTypeDS_NC_O :: CtOrigin   -- origin used for instantiation only
                  -> UserTypeCtxt
-                 -> Maybe a
+                 -> Maybe (HsExpr GhcRn)
                  -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
 -- Just like tcSubType, but with the additional precondition that
 -- ty_expected is deeply skolemised
 tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected
   = case ty_expected of
-      Infer inf_res -> fillInferResult_Inst inst_orig ty_actual inf_res
+      Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
       Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty
          where
            eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty
-                                  , uo_thing = mkErrorThing <$> m_thing }
+                                  , uo_thing  = ppr <$> m_thing
+                                  , uo_visible = True }
 
 ---------------
 tc_sub_tc_type :: CtOrigin   -- used when calling uType
@@ -643,7 +655,7 @@ tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected
          vcat [ text "ty_actual   =" <+> ppr ty_actual
               , text "ty_expected =" <+> ppr ty_expected ]
        ; mkWpCastN <$>
-         uType eq_orig TypeLevel ty_actual ty_expected }
+         uType TypeLevel eq_orig ty_actual ty_expected }
 
   | otherwise   -- This is the general case
   = do { traceTc "tc_sub_tc_type (general case)" $
@@ -738,7 +750,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
     --    go ty_a (TyVarTy alpha)
     -- which, in the impredicative case unified  alpha := ty_a
     -- where th_a is a polytype.  Not only is this probably bogus (we
-    -- simply do not have decent story for imprdicative types), but it
+    -- simply do not have decent story for impredicative types), but it
     -- caused Trac #12616 because (also bizarrely) 'deriving' code had
     -- -XImpredicativeTypes on.  I deleted the entire case.
 
@@ -746,8 +758,9 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
       | not (isPredTy act_arg)
       , not (isPredTy exp_arg)
       = -- See Note [Co/contra-variance of subsumption checking]
-        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt act_res exp_res
-           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig ctxt exp_arg act_arg
+        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt       act_res exp_res
+           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg
+                         -- GenSigCtxt: See Note [Setting the argument context]
            ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }
                -- arg_wrap :: exp_arg ~> act_arg
                -- res_wrap :: act-res ~> exp_res
@@ -789,45 +802,58 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
                                   -> eq_orig { uo_actual = rho_a }
                                 _ -> eq_orig
 
-                        ; cow <- uType eq_orig' TypeLevel rho_a ty_expected
+                        ; cow <- uType TypeLevel eq_orig' rho_a ty_expected
                         ; return (mkWpCastN cow <.> wrap) }
 
 
      -- use versions without synonyms expanded
-    unify = mkWpCastN <$> uType eq_orig TypeLevel ty_actual ty_expected
+    unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected
+
+{- Note [Settting the argument context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider we are doing the ambiguity check for the (bogus)
+  f :: (forall a b. C b => a -> a) -> Int
+
+We'll call
+   tcSubType ((forall a b. C b => a->a) -> Int )
+             ((forall a b. C b => a->a) -> Int )
+
+with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing
+on the argument type of the (->) -- and at that point we want to switch
+to a UserTypeCtxt of GenSigCtxt.  Why?
+
+* Error messages.  If we stick with FunSigCtxt we get errors like
+     * Could not deduce: C b
+       from the context: C b0
+        bound by the type signature for:
+            f :: forall a b. C b => a->a
+  But of course f does not have that type signature!
+  Example tests: T10508, T7220a, Simple14
+
+* Implications. We may decide to build an implication for the whole
+  ambiguity check, but we don't need one for each level within it,
+  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.
+  See Note [When to build an implication]
+-}
 
 -----------------
 -- needs both un-type-checked (for origins) and type-checked (for wrapping)
 -- expressions
 tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
              -> TcM (HsExpr GhcTcId)
-tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr)
+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr
 
 -- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more
 -- convenient.
-tcWrapResultO :: CtOrigin -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
                -> TcM (HsExpr GhcTcId)
-tcWrapResultO orig expr actual_ty res_ty
+tcWrapResultO orig rn_expr expr actual_ty res_ty
   = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty
                                       , text "Expected:" <+> ppr res_ty ])
        ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt
-                                 (Just expr) actual_ty res_ty
+                                 (Just rn_expr) actual_ty res_ty
        ; return (mkHsWrap cow expr) }
 
------------------------------------
-wrapFunResCoercion
-        :: [TcType]        -- Type of args
-        -> HsWrapper       -- HsExpr a -> HsExpr b
-        -> TcM HsWrapper   -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b)
-wrapFunResCoercion arg_tys co_fn_res
-  | isIdHsWrapper co_fn_res
-  = return idHsWrapper
-  | null arg_tys
-  = return co_fn_res
-  | otherwise
-  = do  { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys
-        ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) }
-
 
 {- **********************************************************************
 %*                                                                      *
@@ -851,24 +877,24 @@ tcInfer instantiate tc_check
        ; res_ty <- readExpType res_ty
        ; return (result, res_ty) }
 
-fillInferResult_Inst :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
--- If wrap = fillInferResult_Inst t1 t2
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- If wrap = fillInferResult t1 t2
 --    => wrap :: t1 ~> t2
 -- See Note [Deep instantiation of InferResult]
-fillInferResult_Inst orig ty inf_res@(IR { ir_inst = instantiate_me })
+fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me })
   | instantiate_me
   = do { (wrap, rho) <- deeplyInstantiate orig ty
-       ; co <- fillInferResult rho inf_res
+       ; co <- fill_infer_result rho inf_res
        ; return (mkWpCastN co <.> wrap) }
 
   | otherwise
-  = do { co <- fillInferResult ty inf_res
+  = do { co <- fill_infer_result ty inf_res
        ; return (mkWpCastN co) }
 
-fillInferResult :: TcType -> InferResult -> TcM TcCoercionN
--- If wrap = fillInferResult t1 t2
+fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN
+-- If wrap = fill_infer_result t1 t2
 --    => wrap :: t1 ~> t2
-fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
+fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
                             , ir_ref = ref })
   = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty
 
@@ -885,7 +911,7 @@ fillInferResult orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
       = do { let ty_lvl = tcTypeLevel ty
            ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),
                        ppr u $$ ppr res_lvl $$ ppr ty_lvl $$
-                       ppr ty <+> ppr (typeKind ty) $$ ppr orig_ty )
+                       ppr ty <+> dcolon <+> ppr (typeKind ty) $$ ppr orig_ty )
            ; cts <- readTcRef ref
            ; case cts of
                Just already_there -> pprPanic "writeExpType"
@@ -909,7 +935,7 @@ has the ir_inst flag.
     f :: forall {a}. a -> forall b. Num b => b -> b -> b
   This is surely confusing for users.
 
-  And worse, the the monomorphism restriction won't properly. The MR is
+  And worse, the monomorphism restriction won't work properly. The MR is
   dealt with in simplifyInfer, and simplifyInfer has no way of
   instantiating. This could perhaps be worked around, but it may be
   hard to know even when instantiation should happen.
@@ -958,7 +984,8 @@ promoteTcType dest_lvl ty
            ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)
            ; let eq_orig = TypeEqOrigin { uo_actual   = ty
                                         , uo_expected = prom_ty
-                                        , uo_thing    = Nothing }
+                                        , uo_thing    = Nothing
+                                        , uo_visible  = False }
 
            ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
            ; return (co, prom_ty) }
@@ -969,9 +996,10 @@ promoteTcType dest_lvl ty
            ; let ty_kind = typeKind ty
                  kind_orig = TypeEqOrigin { uo_actual   = ty_kind
                                           , uo_expected = res_kind
-                                          , uo_thing    = Nothing }
-           ; ki_co <- uType kind_orig KindLevel (typeKind ty) res_kind
-           ; let co = mkTcNomReflCo ty `mkTcCoherenceRightCo` ki_co
+                                          , uo_thing    = Nothing
+                                          , uo_visible  = False }
+           ; ki_co <- uType KindLevel kind_orig (typeKind ty) res_kind
+           ; let co = mkTcGReflRightCo Nominal ty ki_co
            ; return (co, ty `mkCastTy` ki_co) }
 
 {- Note [Promoting a type]
@@ -1024,7 +1052,7 @@ to
         (forall a. a->a) -> alpha[l+1]
 and emit the constraint
         [W] alpha[l+1] ~ Int
-Now the poromoted type can fill the ref cell, while the emitted
+Now the promoted type can fill the ref cell, while the emitted
 equality can float or not, according to the usual rules.
 
 But that's not quite right!  We are exposing the arrow! We could
@@ -1037,7 +1065,7 @@ Here we abstract over the '->' inside the forall, in case that
 is subject to an equality constraint from a GADT match.
 
 Note that we kept the outer (->) because that's part of
-the polymorphic "shape".  And becauuse of impredicativity,
+the polymorphic "shape".  And because of impredicativity,
 GADT matches can't give equalities that affect polymorphic
 shape.
 
@@ -1115,35 +1143,81 @@ checkConstraints :: SkolemInfo
                  -> TcM (TcEvBinds, result)
 
 checkConstraints skol_info skol_tvs given thing_inside
-  = do { (implics, ev_binds, result)
-            <- buildImplication skol_info skol_tvs given thing_inside
-       ; emitImplications implics
-       ; return (ev_binds, result) }
-
-buildImplication :: SkolemInfo
-                 -> [TcTyVar]           -- Skolems
-                 -> [EvVar]             -- Given
-                 -> TcM result
-                 -> TcM (Bag Implication, TcEvBinds, result)
-buildImplication skol_info skol_tvs given thing_inside
-  = do { tc_lvl <- getTcLevel
-       ; deferred_type_errors <- goptM Opt_DeferTypeErrors <||>
-                                 goptM Opt_DeferTypedHoles
-       ; if null skol_tvs && null given && (not deferred_type_errors ||
-                                            not (isTopTcLevel tc_lvl))
-         then do { res <- thing_inside
-                 ; return (emptyBag, emptyTcEvBinds, res) }
-      -- Fast path.  We check every function argument with
-      -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.
-      -- But with the solver producing unlifted equalities, we need
-      -- to have an EvBindsVar for them when they might be deferred to
-      -- runtime. Otherwise, they end up as top-level unlifted bindings,
-      -- which are verboten. See also Note [Deferred errors for coercion holes]
-      -- in TcErrors.
+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given
+
+       ; if implication_needed
+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)
+                 ; emitImplications implics
+                 ; return (ev_binds, result) }
+
+         else -- Fast path.  We check every function argument with
+              -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.
+              -- So this fast path is well-exercised
+              do { res <- thing_inside
+                 ; return (emptyTcEvBinds, res) } }
+
+checkTvConstraints :: SkolemInfo
+                   -> Maybe SDoc  -- User-written telescope, if present
+                   -> TcM ([TcTyVar], result)
+                   -> TcM ([TcTyVar], result)
+
+checkTvConstraints skol_info m_telescope thing_inside
+  = do { (tclvl, wanted, (skol_tvs, result))
+             <- pushLevelAndCaptureConstraints thing_inside
+
+       ; if isEmptyWC wanted
+         then return ()
+         else do { ev_binds <- newNoTcEvBinds
+                 ; implic   <- newImplication
+                 ; emitImplication $
+                   implic { ic_tclvl     = tclvl
+                          , ic_skols     = skol_tvs
+                          , ic_no_eqs    = True
+                          , ic_telescope = m_telescope
+                          , ic_wanted    = wanted
+                          , ic_binds     = ev_binds
+                          , ic_info      = skol_info } }
+       ; return (skol_tvs, result) }
+
+
+implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool
+-- See Note [When to build an implication]
+implicationNeeded skol_info skol_tvs given
+  | null skol_tvs
+  , null given
+  , not (alwaysBuildImplication skol_info)
+  = -- Empty skolems and givens
+    do { tc_lvl <- getTcLevel
+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are
+         then return False             -- already inside an implication
          else
-    do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
-       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
-       ; return (implics, ev_binds, result) }}
+    do { dflags <- getDynFlags       -- If any deferral can happen,
+                                     -- we must build an implication
+       ; return (gopt Opt_DeferTypeErrors dflags ||
+                 gopt Opt_DeferTypedHoles dflags ||
+                 gopt Opt_DeferOutOfScopeVariables dflags) } }
+
+  | otherwise     -- Non-empty skolems or givens
+  = return True   -- Definitely need an implication
+
+alwaysBuildImplication :: SkolemInfo -> Bool
+-- See Note [When to build an implication]
+alwaysBuildImplication _ = False
+
+{-  Commmented out for now while I figure out about error messages.
+    See Trac #14185
+
+alwaysBuildImplication (SigSkol ctxt _ _)
+  = case ctxt of
+      FunSigCtxt {} -> True  -- RHS of a binding with a signature
+      _             -> False
+alwaysBuildImplication (RuleSkol {})      = True
+alwaysBuildImplication (InstSkol {})      = True
+alwaysBuildImplication (FamInstSkol {})   = True
+alwaysBuildImplication _                  = False
+-}
 
 buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]
                    -> [EvVar] -> WantedConstraints
@@ -1157,21 +1231,52 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted
   = return (emptyBag, emptyTcEvBinds)
 
   | otherwise
-  = ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
+  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )
+      -- Why allow TyVarTvs? Because implicitly declared kind variables in
+      -- non-CUSK type declarations are TyVarTvs, and we need to bring them
+      -- into scope as a skolem in an implication. This is OK, though,
+      -- because TyVarTvs will always remain tyvars, even after unification.
     do { ev_binds_var <- newTcEvBinds
-       ; env <- getLclEnv
-       ; let implic = Implic { ic_tclvl = tclvl
-                             , ic_skols = skol_tvs
-                             , ic_no_eqs = False
-                             , ic_given = given
-                             , ic_wanted = wanted
-                             , ic_status  = IC_Unsolved
-                             , ic_binds = ev_binds_var
-                             , ic_env = env
-                             , ic_needed = emptyVarSet
-                             , ic_info = skol_info }
-
-       ; return (unitBag implic, TcEvBinds ev_binds_var) }
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_skols  = skol_tvs
+                              , ic_given  = given
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = skol_info }
+
+       ; return (unitBag implic', TcEvBinds ev_binds_var) }
+
+{- Note [When to build an implication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have some 'skolems' and some 'givens', and we are
+considering whether to wrap the constraints in their scope into an
+implication.  We must /always/ so if either 'skolems' or 'givens' are
+non-empty.  But what if both are empty?  You might think we could
+always drop the implication.  Other things being equal, the fewer
+implications the better.  Less clutter and overhead.  But we must
+take care:
+
+* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,
+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.
+  We must have an EvBindsVar those bindings!, otherwise they end up as
+  top-level unlifted bindings, which are verboten. This only matters
+  at top level, so we check for that
+  See also Note [Deferred errors for coercion holes] in TcErrors.
+  cf Trac #14149 for an example of what goes wrong.
+
+* If you have
+     f :: Int;  f = f_blah
+     g :: Bool; g = g_blah
+  If we don't build an implication for f or g (no tyvars, no givens),
+  the constraints for f_blah and g_blah are solved together.  And that
+  can yield /very/ confusing error messages, because we can get
+      [W] C Int b1    -- from f_blah
+      [W] C Int b2    -- from g_blan
+  and fundpes can yield [D] b1 ~ b2, even though the two functions have
+  literally nothing to do with each other.  Trac #14185 is an example.
+  Building an implication keeps them separage.
+-}
 
 {-
 ************************************************************************
@@ -1184,41 +1289,25 @@ The exported functions are all defined as versions of some
 non-exported generic functions.
 -}
 
-unifyType :: Outputable a => Maybe a   -- ^ If present, has type 'ty1'
+unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'
           -> TcTauType -> TcTauType -> TcM TcCoercionN
 -- Actual and expected types
 -- Returns a coercion : ty1 ~ ty2
 unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
-                          uType origin TypeLevel ty1 ty2
+                          uType TypeLevel origin ty1 ty2
   where
     origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
-                          , uo_thing  = mkErrorThing <$> thing }
-
--- | Use this instead of 'Nothing' when calling 'unifyType' without
--- a good "thing" (where the "thing" has the "actual" type passed in)
--- This has an 'Outputable' instance, avoiding amgiguity problems.
-noThing :: Maybe (HsExpr GhcRn)
-noThing = Nothing
+                          , uo_thing  = ppr <$> thing
+                          , uo_visible = True } -- always called from a visible context
 
-unifyKind :: Outputable a => Maybe a -> TcKind -> TcKind -> TcM CoercionN
+unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
 unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
-                          uType origin KindLevel ty1 ty2
+                          uType KindLevel origin ty1 ty2
   where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
-                              , uo_thing  = mkErrorThing <$> thing }
+                              , uo_thing  = ppr <$> thing
+                              , uo_visible = True } -- also always from a visible context
 
 ---------------
-unifyPred :: PredType -> PredType -> TcM TcCoercionN
--- Actual and expected types
-unifyPred = unifyType noThing
-
----------------
-unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercionN]
--- Actual and expected types
-unifyTheta theta1 theta2
-  = do  { checkTc (equalLength theta1 theta2)
-                  (vcat [text "Contexts differ in length",
-                         nest 2 $ parens $ text "Use RelaxedPolyRec to allow this"])
-        ; zipWithM unifyPred theta1 theta2 }
 
 {-
 %************************************************************************
@@ -1231,16 +1320,16 @@ uType is the heart of the unifier.
 -}
 
 uType, uType_defer
-  :: CtOrigin
-  -> TypeOrKind
+  :: TypeOrKind
+  -> CtOrigin
   -> TcType    -- ty1 is the *actual* type
   -> TcType    -- ty2 is the *expected* type
-  -> TcM Coercion
+  -> TcM CoercionN
 
 --------------
 -- It is always safe to defer unification to the main constraint solver
 -- See Note [Deferred unification]
-uType_defer origin t_or_k ty1 ty2
+uType_defer t_or_k origin ty1 ty2
   = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
 
        -- Error trace only
@@ -1249,13 +1338,16 @@ uType_defer origin t_or_k ty1 ty2
        ; whenDOptM Opt_D_dump_tc_trace $ do
             { ctxt <- getErrCtxt
             ; doc <- mkErrInfo emptyTidyEnv ctxt
-            ; traceTc "utype_defer" (vcat [ppr co, ppr ty1,
-                                           ppr ty2, pprCtOrigin origin, doc])
+            ; traceTc "utype_defer" (vcat [ debugPprType ty1
+                                          , debugPprType ty2
+                                          , pprCtOrigin origin
+                                          , doc])
+            ; traceTc "utype_defer2" (ppr co)
             }
        ; return co }
 
 --------------
-uType origin t_or_k orig_ty1 orig_ty2
+uType t_or_k origin orig_ty1 orig_ty2
   = do { tclvl <- getTcLevel
        ; traceTc "u_tys" $ vcat
               [ text "tclvl" <+> ppr tclvl
@@ -1267,10 +1359,21 @@ uType origin t_or_k orig_ty1 orig_ty2
             else traceTc "u_tys yields coercion:" (ppr co)
        ; return co }
   where
-    go :: TcType -> TcType -> TcM Coercion
+    go :: TcType -> TcType -> TcM CoercionN
         -- The arguments to 'go' are always semantically identical
         -- to orig_ty{1,2} except for looking through type synonyms
 
+     -- Unwrap casts before looking for variables. This way, we can easily
+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we
+     -- didn't do it this way, and then the unification above was deferred.
+    go (CastTy t1 co1) t2
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }
+
+    go t1 (CastTy t2 co2)
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }
+
         -- Variables; go for uVar
         -- Note that we pass in *original* (before synonym expansion),
         -- so that type variables tend to get filled in with
@@ -1291,7 +1394,7 @@ uType origin t_or_k orig_ty1 orig_ty2
       -- See Note [Expanding synonyms during unification]
     go ty1@(TyConApp tc1 []) (TyConApp tc2 [])
       | tc1 == tc2
-      = return $ mkReflCo Nominal ty1
+      = return $ mkNomReflCo ty1
 
         -- See Note [Expanding synonyms during unification]
         --
@@ -1305,18 +1408,10 @@ uType origin t_or_k orig_ty1 orig_ty2
       | Just ty1' <- tcView ty1 = go ty1' ty2
       | Just ty2' <- tcView ty2 = go ty1  ty2'
 
-    go (CastTy t1 co1) t2
-      = do { co_tys <- go t1 t2
-           ; return (mkCoherenceLeftCo co_tys co1) }
-
-    go t1 (CastTy t2 co2)
-      = do { co_tys <- go t1 t2
-           ; return (mkCoherenceRightCo co_tys co2) }
-
         -- Functions (or predicate functions) just check the two parts
     go (FunTy fun1 arg1) (FunTy fun2 arg2)
-      = do { co_l <- uType origin t_or_k fun1 fun2
-           ; co_r <- uType origin t_or_k arg1 arg2
+      = do { co_l <- uType t_or_k origin fun1 fun2
+           ; co_r <- uType t_or_k origin arg1 arg2
            ; return $ mkFunCo Nominal co_l co_r }
 
         -- Always defer if a type synonym family (type function)
@@ -1330,8 +1425,11 @@ uType origin t_or_k orig_ty1 orig_ty2
       -- See Note [Mismatched type lists and application decomposition]
       | tc1 == tc2, equalLength tys1 tys2
       = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
-        do { cos <- zipWithM (uType origin t_or_k) tys1 tys2
+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
            ; return $ mkTyConAppCo Nominal tc1 cos }
+      where
+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
+                       (tcTyConVisibilities tc1)
 
     go (LitTy m) ty@(LitTy n)
       | m == n
@@ -1341,24 +1439,24 @@ uType origin t_or_k orig_ty1 orig_ty2
         -- Do not decompose FunTy against App;
         -- it's often a type error, so leave it for the constraint solver
     go (AppTy s1 t1) (AppTy s2 t2)
-      = go_app s1 t1 s2 t2
+      = go_app (isNextArgVisible s1) s1 t1 s2 t2
 
     go (AppTy s1 t1) (TyConApp tc2 ts2)
       | Just (ts2', t2') <- snocView ts2
       = ASSERT( mightBeUnsaturatedTyCon tc2 )
-        go_app s1 t1 (TyConApp tc2 ts2') t2'
+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
 
     go (TyConApp tc1 ts1) (AppTy s2 t2)
       | Just (ts1', t1') <- snocView ts1
       = ASSERT( mightBeUnsaturatedTyCon tc1 )
-        go_app (TyConApp tc1 ts1') t1' s2 t2
+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
 
     go (CoercionTy co1) (CoercionTy co2)
       = do { let ty1 = coercionType co1
                  ty2 = coercionType co2
-           ; kco <- uType (KindEqOrigin orig_ty1 (Just orig_ty2) origin
+           ; kco <- uType KindLevel
+                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin
                                         (Just t_or_k))
-                          KindLevel
                           ty1 ty2
            ; return $ mkProofIrrelCo Nominal kco co1 co2 }
 
@@ -1369,12 +1467,15 @@ uType origin t_or_k orig_ty1 orig_ty2
     ------------------
     defer ty1 ty2   -- See Note [Check for equality before deferring]
       | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
-      | otherwise          = uType_defer origin t_or_k ty1 ty2
+      | otherwise          = uType_defer t_or_k origin ty1 ty2
 
     ------------------
-    go_app s1 t1 s2 t2
-      = do { co_s <- uType origin t_or_k s1 s2
-           ; co_t <- uType origin t_or_k t1 t2
+    go_app vis s1 t1 s2 t2
+      = do { co_s <- uType t_or_k origin s1 s2
+           ; let arg_origin
+                   | vis       = origin
+                   | otherwise = toInvisibleOrigin origin
+           ; co_t <- uType t_or_k arg_origin t1 t2
            ; return $ mkAppCo co_s co_t }
 
 {- Note [Check for equality before deferring]
@@ -1421,6 +1522,9 @@ We expand synonyms during unification, but:
    more likely that the inferred types will mention type synonyms
    understandable to the user
 
+ * Similarly, we expand *after* the CastTy case, just in case the
+   CastTy wraps a variable.
+
  * We expand *before* the TyConApp case.  For example, if we have
       type Phantom a = Int
    and are unifying
@@ -1528,84 +1632,141 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
     go dflags cur_lvl
       | canSolveByUnification cur_lvl tv1 ty2
       , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2
-      = do { co_k <- uType kind_origin KindLevel (typeKind ty2') (tyVarKind tv1)
-           ; co   <- updateMeta tv1 ty2' co_k
-           ; return (maybe_sym swapped co) }
+      = do { co_k <- uType KindLevel kind_origin (typeKind ty2') (tyVarKind tv1)
+           ; traceTc "uUnfilledVar2 ok" $
+             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
+                  , ppr ty2 <+> dcolon <+> ppr (typeKind  ty2)
+                  , ppr (isTcReflCo co_k), ppr co_k ]
+
+           ; if isTcReflCo co_k  -- only proceed if the kinds matched.
+
+             then do { writeMetaTyVar tv1 ty2'
+                     ; return (mkTcNomReflCo ty2') }
+
+             else defer } -- This cannot be solved now.  See TcCanonical
+                          -- Note [Equalities with incompatible kinds]
 
       | otherwise
-      = unSwap swapped (uType_defer origin t_or_k) ty1 ty2
+      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)
                -- Occurs check or an untouchable: just defer
                -- NB: occurs check isn't necessarily fatal:
                --     eg tv1 occured in type family parameter
+            ; defer }
 
     ty1 = mkTyVarTy tv1
     kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)
 
--- | apply sym iff swapped
-maybe_sym :: SwapFlag -> Coercion -> Coercion
-maybe_sym IsSwapped  = mkSymCo
-maybe_sym NotSwapped = id
+    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
 
 swapOverTyVars :: TcTyVar -> TcTyVar -> Bool
 swapOverTyVars tv1 tv2
-  | isFmvTyVar tv1 = False  -- See Note [Fmv Orientation Invariant]
-  | isFmvTyVar tv2 = True
-
-  | Just lvl1 <- metaTyVarTcLevel_maybe tv1
-      -- If tv1 is touchable, swap only if tv2 is also
-      -- touchable and it's strictly better to update the latter
-      -- But see Note [Avoid unnecessary swaps]
-  = case metaTyVarTcLevel_maybe tv2 of
-      Nothing   -> False
-      Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True
-                | lvl1 `strictlyDeeperThan` lvl2 -> False
-                | otherwise                      -> nicer_to_update tv2
-
-  -- So tv1 is not a meta tyvar
-  -- If only one is a meta tyvar, put it on the left
-  -- This is not because it'll be solved; but because
-  -- the floating step looks for meta tyvars on the left
-  | isMetaTyVar tv2 = True
-
-  -- So neither is a meta tyvar (including FlatMetaTv)
-
-  -- If only one is a flatten skolem, put it on the left
-  -- See Note [Eliminate flat-skols]
-  | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True
+  -- Level comparison: see Note [TyVar/TyVar orientation]
+  | lvl1 `strictlyDeeperThan` lvl2 = False
+  | lvl2 `strictlyDeeperThan` lvl1 = True
 
-  | otherwise = False
+  -- Priority: see Note [TyVar/TyVar orientation]
+  | pri1 > pri2 = False
+  | pri2 > pri1 = True
 
-  where
-    nicer_to_update tv2
-      =  (isSigTyVar tv1                 && not (isSigTyVar tv2))
-      || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1)))
+  -- Names: see Note [TyVar/TyVar orientation]
+  | isSystemName tv2_name, not (isSystemName tv1_name) = True
 
--- @trySpontaneousSolve wi@ solves equalities where one side is a
--- touchable unification variable.
--- Returns True <=> spontaneous solve happened
-canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool
-canSolveByUnification tclvl tv xi
-  | isTouchableMetaTyVar tclvl tv
-  = case metaTyVarInfo tv of
-      SigTv -> is_tyvar xi
-      _     -> True
+  | otherwise = False
 
-  | otherwise    -- Untouchable
-  = False
   where
-    is_tyvar xi
-      = case tcGetTyVar_maybe xi of
-          Nothing -> False
-          Just tv -> case tcTyVarDetails tv of
-                       MetaTv { mtv_info = info }
-                                   -> case info of
-                                        SigTv -> True
-                                        _     -> False
-                       SkolemTv {} -> True
-                       RuntimeUnk  -> True
-
-{- Note [Fmv Orientation Invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    lvl1 = tcTyVarLevel tv1
+    lvl2 = tcTyVarLevel tv2
+    pri1 = lhsPriority tv1
+    pri2 = lhsPriority tv2
+    tv1_name = Var.varName tv1
+    tv2_name = Var.varName tv2
+
+
+lhsPriority :: TcTyVar -> Int
+-- Higher => more important to be on the LHS
+-- See Note [TyVar/TyVar orientation]
+lhsPriority tv
+  = ASSERT2( isTyVar tv, ppr tv)
+    case tcTyVarDetails tv of
+      RuntimeUnk  -> 0
+      SkolemTv {} -> 0
+      MetaTv { mtv_info = info } -> case info of
+                                     FlatSkolTv -> 1
+                                     TyVarTv    -> 2
+                                     TauTv      -> 3
+                                     FlatMetaTv -> 4
+{- Note [TyVar/TyVar orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?
+This is a surprisingly tricky question!
+
+First note: only swap if you have to!
+   See Note [Avoid unnecessary swaps]
+
+So we look for a positive reason to swap, using a three-step test:
+
+* Level comparison. If 'a' has deeper level than 'b',
+  put 'a' on the left.  See Note [Deeper level on the left]
+
+* Priority.  If the levels are the same, look at what kind of
+  type variable it is, using 'lhsPriority'
+
+  - FlatMetaTv: Always put on the left.
+    See Note [Fmv Orientation Invariant]
+    NB: FlatMetaTvs always have the current level, never an
+        outer one.  So nothing can be deeper than a FlatMetaTv
+
+
+  - TyVarTv/TauTv: if we have  tyv_tv ~ tau_tv, put tau_tv
+                   on the left because there are fewer
+                   restrictions on updating TauTvs
+
+  - TyVarTv/TauTv:  put on the left either
+     a) Because it's touchable and can be unified, or
+     b) Even if it's not touchable, TcSimplify.floatEqualities
+        looks for meta tyvars on the left
+
+  - FlatSkolTv: Put on the left in preference to a SkolemTv
+                See Note [Eliminate flat-skols]
+
+* Names. If the level and priority comparisons are all
+  equal, try to eliminate a TyVars with a System Name in
+  favour of ones with a Name derived from a user type signature
+
+* Age.  At one point in the past we tried to break any remaining
+  ties by eliminating the younger type variable, based on their
+  Uniques.  See Note [Eliminate younger unification variables]
+  (which also explains why we don't do this any more)
+
+Note [Deeper level on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The most important thing is that we want to put tyvars with
+the deepest level on the left.  The reason to do so differs for
+Wanteds and Givens, but either way, deepest wins!  Simple.
+
+* Wanteds.  Putting the deepest variable on the left maximise the
+  chances that it's a touchable meta-tyvar which can be solved.
+
+* Givens. Suppose we have something like
+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]
+
+  If we orient the Given a[2] on the left, we'll rewrite the Wanted to
+  (beta[1] ~ b[1]), and that can float out of the implication.
+  Otherwise it can't.  By putting the deepest variable on the left
+  we maximise our changes of eliminating skolem capture.
+
+  See also TcSMonad Note [Let-bound skolems] for another reason
+  to orient with the deepest skolem on the left.
+
+  IMPORTANT NOTE: this test does a level-number comparison on
+  skolems, so it's important that skolems have (accurate) level
+  numbers.
+
+See Trac #15009 for an further analysis of why "deepest on the left"
+is a good plan.
+
+Note [Fmv Orientation Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    * We always orient a constraint
         fmv ~ alpha
      with fmv on the left, even if alpha is
@@ -1638,14 +1799,88 @@ T10226, T10009.)
           [WD] F fmv ~ fmv, [WD] fmv ~ a
     And now we are stuck.
 
-So instead the Fmv Orientation Invariant puts te fmv on the
+So instead the Fmv Orientation Invariant puts the fmv on the
 left, giving
       [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a
 
     Now we get alpha:=a, and everything works out
 
-Note [Prevent unification with type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Eliminate flat-skols]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have  [G] Num (F [a])
+then we flatten to
+     [G] Num fsk
+     [G] F [a] ~ fsk
+where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
+      type instance F [a] = a
+then we'll reduce the second constraint to
+     [G] a ~ fsk
+and then replace all uses of 'a' with fsk.  That's bad because
+in error messages instead of saying 'a' we'll say (F [a]).  In all
+places, including those where the programmer wrote 'a' in the first
+place.  Very confusing!  See Trac #7862.
+
+Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
+the fsk.
+
+Note [Avoid unnecessary swaps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we swap without actually improving matters, we can get an infinite loop.
+Consider
+    work item:  a ~ b
+   inert item:  b ~ c
+We canonicalise the work-item to (a ~ c).  If we then swap it before
+adding to the inert set, we'll add (c ~ a), and therefore kick out the
+inert guy, so we get
+   new work item:  b ~ c
+   inert item:     c ~ a
+And now the cycle just repeats
+
+Note [Eliminate younger unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a choice of unifying
+     alpha := beta   or   beta := alpha
+we try, if possible, to eliminate the "younger" one, as determined
+by `ltUnique`.  Reason: the younger one is less likely to appear free in
+an existing inert constraint, and hence we are less likely to be forced
+into kicking out and rewriting inert constraints.
+
+This is a performance optimisation only.  It turns out to fix
+Trac #14723 all by itself, but clearly not reliably so!
+
+It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).
+But, to my surprise, it didn't seem to make any significant difference
+to the compiler's performance, so I didn't take it any further.  Still
+it seemed to too nice to discard altogether, so I'm leaving these
+notes.  SLPJ Jan 18.
+-}
+
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable.
+-- Returns True <=> spontaneous solve happened
+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool
+canSolveByUnification tclvl tv xi
+  | isTouchableMetaTyVar tclvl tv
+  = case metaTyVarInfo tv of
+      TyVarTv -> is_tyvar xi
+      _       -> True
+
+  | otherwise    -- Untouchable
+  = False
+  where
+    is_tyvar xi
+      = case tcGetTyVar_maybe xi of
+          Nothing -> False
+          Just tv -> case tcTyVarDetails tv of
+                       MetaTv { mtv_info = info }
+                                   -> case info of
+                                        TyVarTv -> True
+                                        _       -> False
+                       SkolemTv {} -> True
+                       RuntimeUnk  -> True
+
+{- Note [Prevent unification with type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We prevent unification with type families because of an uneasy compromise.
 It's perfectly sound to unify with type families, and it even improves the
 error messages in the testsuite. It also modestly improves performance, at
@@ -1768,38 +2003,26 @@ lookupTcTyVar tyvar
   where
     details = tcTyVarDetails tyvar
 
--- | Fill in a meta-tyvar
-updateMeta :: TcTyVar            -- ^ tv to fill in, tv :: k1
-           -> TcType             -- ^ ty2 :: k2
-           -> Coercion           -- ^ kind_co :: k2 ~N k1
-           -> TcM Coercion       -- ^ :: tv ~N ty2 (= ty2 |> kind_co ~N ty2)
-updateMeta tv1 ty2 kind_co
-  = do { let ty2'     = ty2 `mkCastTy` kind_co
-             ty2_refl = mkNomReflCo ty2
-             co       = mkCoherenceLeftCo ty2_refl kind_co
-       ; writeMetaTyVar tv1 ty2'
-       ; return co }
-
 {-
 Note [Unifying untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We treat an untouchable type variable as if it was a skolem.  That
-ensures it won't unify with anything.  It's a slight had, because
+ensures it won't unify with anything.  It's a slight hack, because
 we return a made-up TcTyVarDetails, but I think it works smoothly.
 -}
 
 -- | Breaks apart a function kind into its pieces.
-matchExpectedFunKind :: Arity           -- ^ # of args remaining, only for errors
-                     -> TcType          -- ^ type, only for errors
+matchExpectedFunKind :: Outputable fun
+                     => fun             -- ^ type, only for errors
                      -> TcKind          -- ^ function kind
                      -> TcM (Coercion, TcKind, TcKind)
                                   -- ^ co :: old_kind ~ arg -> res
-matchExpectedFunKind num_args_remaining ty = go
+matchExpectedFunKind hs_ty = go
   where
     go k | Just k' <- tcView k = go k'
 
     go k@(TyVarTy kvar)
-      | isTcTyVar kvar, isMetaTyVar kvar
+      | isMetaTyVar kvar
       = do { maybe_kind <- readMetaTyVar kvar
            ; case maybe_kind of
                 Indirect fun_kind -> go fun_kind
@@ -1812,12 +2035,12 @@ matchExpectedFunKind num_args_remaining ty = go
       = do { arg_kind <- newMetaKindVar
            ; res_kind <- newMetaKindVar
            ; let new_fun = mkFunTy arg_kind res_kind
-                 thing   = mkTypeErrorThingArgs ty num_args_remaining
                  origin  = TypeEqOrigin { uo_actual   = k
                                         , uo_expected = new_fun
-                                        , uo_thing    = Just thing
+                                        , uo_thing    = Just (ppr hs_ty)
+                                        , uo_visible  = True
                                         }
-           ; co <- uType origin KindLevel k new_fun
+           ; co <- uType KindLevel origin k new_fun
            ; return (co, arg_kind, res_kind) }
 
 
@@ -1828,38 +2051,12 @@ matchExpectedFunKind num_args_remaining ty = go
 ********************************************************************* -}
 
 
-{- Note [Occurs check expansion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid
-of occurrences of tv outside type function arguments, if that is
-possible; otherwise, it returns Nothing.
-
-For example, suppose we have
-  type F a b = [a]
-Then
-  occCheckExpand b (F Int b) = Just [Int]
-but
-  occCheckExpand a (F a Int) = Nothing
-
-We don't promise to do the absolute minimum amount of expanding
-necessary, but we try not to do expansions we don't need to.  We
-prefer doing inner expansions first.  For example,
-  type F a b = (a, Int, a, [a])
-  type G b   = Char
-We have
-  occCheckExpand b (F (G b)) = Just (F Char)
-even though we could also expand F to get rid of b.
-
-The two variants of the function are to support TcUnify.checkTauTvUpdate,
-which wants to prevent unification with type families. For more on this
-point, see Note [Prevent unification with type families] in TcUnify.
-
-Note [Occurrence checking: look inside kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{-  Note [Occurrence checking: look inside kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are considering unifying
    (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)
 This may be an error (what is that alpha doing inside beta's kind?),
-but we must not make the mistake of actuallyy unifying or we'll
+but we must not make the mistake of actually unifying or we'll
 build an infinite data structure.  So when looking for occurrences
 of alpha in the rhs, we must look in the kinds of type variables
 that occur there.
@@ -1926,7 +2123,7 @@ occCheckForErrors dflags tv ty
   = case preCheck dflags True tv ty of
       OC_OK _   -> OC_OK ()
       OC_Bad    -> OC_Bad
-      OC_Occurs -> case occCheckExpand tv ty of
+      OC_Occurs -> case occCheckExpand [tv] ty of
                      Nothing -> OC_Occurs
                      Just _  -> OC_OK ()
 
@@ -1964,7 +2161,7 @@ metaTyVarUpdateOK dflags tv ty
          -- See Note [Prevent unification with type families]
       OC_OK _   -> Just ty
       OC_Bad    -> Nothing  -- forall or type function
-      OC_Occurs -> occCheckExpand tv ty
+      OC_Occurs -> occCheckExpand [tv] ty
 
 preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> OccCheckResult ()
 -- A quick check for
@@ -1999,7 +2196,7 @@ preCheck dflags ty_fam_ok tv ty
     fast_check (AppTy fun arg) = fast_check fun >> fast_check arg
     fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co
     fast_check (CoercionTy co) = fast_check_co co
-    fast_check (ForAllTy (TvBndr tv' _) ty)
+    fast_check (ForAllTy (Bndr tv' _) ty)
        | not impredicative_ok = OC_Bad
        | tv == tv'            = ok
        | otherwise = do { fast_check_occ (tyVarKind tv')
@@ -2025,120 +2222,10 @@ preCheck dflags ty_fam_ok tv ty
       | not (ty_fam_ok        || isFamFreeTyCon tc) = True
       | otherwise                                   = False
 
-occCheckExpand :: TcTyVar -> TcType -> Maybe TcType
--- See Note [Occurs check expansion]
--- We may have needed to do some type synonym unfolding in order to
--- get rid of the variable (or forall), so we also return the unfolded
--- version of the type, which is guaranteed to be syntactically free
--- of the given type variable.  If the type is already syntactically
--- free of the variable, then the same type is returned.
-occCheckExpand tv ty
-  = go emptyVarEnv ty
-  where
-    go :: VarEnv TyVar -> Type -> Maybe Type
-          -- The VarEnv carries mappings necessary
-          -- because of kind expansion
-    go env (TyVarTy tv')
-      | tv == tv'                         = Nothing
-      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')
-      | otherwise                         = do { k' <- go env (tyVarKind tv')
-                                               ; return (mkTyVarTy $
-                                                         setTyVarKind tv' k') }
-           -- See Note [Occurrence checking: look inside kinds]
-
-    go _   ty@(LitTy {}) = return ty
-    go env (AppTy ty1 ty2) = do { ty1' <- go env ty1
-                                ; ty2' <- go env ty2
-                                ; return (mkAppTy ty1' ty2') }
-    go env (FunTy ty1 ty2) = do { ty1' <- go env ty1
-                                ; ty2' <- go env ty2
-                                ; return (mkFunTy ty1' ty2') }
-    go env ty@(ForAllTy (TvBndr tv' vis) body_ty)
-       | tv == tv'         = return ty
-       | otherwise         = do { ki' <- go env (tyVarKind tv')
-                                ; let tv'' = setTyVarKind tv' ki'
-                                      env' = extendVarEnv env tv' tv''
-                                ; body' <- go env' body_ty
-                                ; return (ForAllTy (TvBndr tv'' vis) body') }
-
-    -- For a type constructor application, first try expanding away the
-    -- offending variable from the arguments.  If that doesn't work, next
-    -- see if the type constructor is a type synonym, and if so, expand
-    -- it and try again.
-    go env ty@(TyConApp tc tys)
-      = case mapM (go env) tys of
-          Just tys' -> return (mkTyConApp tc tys')
-          Nothing | Just ty' <- tcView ty -> go env ty'
-                  | otherwise             -> Nothing
-                      -- Failing that, try to expand a synonym
-
-    go env (CastTy ty co) =  do { ty' <- go env ty
-                                ; co' <- go_co env co
-                                ; return (mkCastTy ty' co') }
-    go env (CoercionTy co) = do { co' <- go_co env co
-                                ; return (mkCoercionTy co') }
-
-    ------------------
-    go_co env (Refl r ty)               = do { ty' <- go env ty
-                                             ; return (mkReflCo r ty') }
-      -- Note: Coercions do not contain type synonyms
-    go_co env (TyConAppCo r tc args)    = do { args' <- mapM (go_co env) args
-                                             ; return (mkTyConAppCo r tc args') }
-    go_co env (AppCo co arg)            = do { co' <- go_co env co
-                                             ; arg' <- go_co env arg
-                                             ; return (mkAppCo co' arg') }
-    go_co env co@(ForAllCo tv' kind_co body_co)
-      | tv == tv'         = return co
-      | otherwise         = do { kind_co' <- go_co env kind_co
-                               ; let tv'' = setTyVarKind tv' $
-                                            pFst (coercionKind kind_co')
-                                     env' = extendVarEnv env tv' tv''
-                               ; body' <- go_co env' body_co
-                               ; return (ForAllCo tv'' kind_co' body') }
-    go_co env (FunCo r co1 co2)         = do { co1' <- go_co env co1
-                                             ; co2' <- go_co env co2
-                                             ; return (mkFunCo r co1' co2') }
-    go_co env (CoVarCo c)               = do { k' <- go env (varType c)
-                                             ; return (mkCoVarCo (setVarType c k')) }
-    go_co env (AxiomInstCo ax ind args) = do { args' <- mapM (go_co env) args
-                                             ; return (mkAxiomInstCo ax ind args') }
-    go_co env (UnivCo p r ty1 ty2)      = do { p' <- go_prov env p
-                                             ; ty1' <- go env ty1
-                                             ; ty2' <- go env ty2
-                                             ; return (mkUnivCo p' r ty1' ty2') }
-    go_co env (SymCo co)                = do { co' <- go_co env co
-                                             ; return (mkSymCo co') }
-    go_co env (TransCo co1 co2)         = do { co1' <- go_co env co1
-                                             ; co2' <- go_co env co2
-                                             ; return (mkTransCo co1' co2') }
-    go_co env (NthCo n co)              = do { co' <- go_co env co
-                                             ; return (mkNthCo n co') }
-    go_co env (LRCo lr co)              = do { co' <- go_co env co
-                                             ; return (mkLRCo lr co') }
-    go_co env (InstCo co arg)           = do { co' <- go_co env co
-                                             ; arg' <- go_co env arg
-                                             ; return (mkInstCo co' arg') }
-    go_co env (CoherenceCo co1 co2)     = do { co1' <- go_co env co1
-                                             ; co2' <- go_co env co2
-                                             ; return (mkCoherenceCo co1' co2') }
-    go_co env (KindCo co)               = do { co' <- go_co env co
-                                             ; return (mkKindCo co') }
-    go_co env (SubCo co)                = do { co' <- go_co env co
-                                             ; return (mkSubCo co') }
-    go_co env (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co env) cs
-                                             ; return (mkAxiomRuleCo ax cs') }
-
-    ------------------
-    go_prov _   UnsafeCoerceProv    = return UnsafeCoerceProv
-    go_prov env (PhantomProv co)    = PhantomProv <$> go_co env co
-    go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co
-    go_prov _   p@(PluginProv _)    = return p
-    go_prov _   p@(HoleProv _)      = return p
-
 canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool
 canUnifyWithPolyType dflags details
   = case details of
-      MetaTv { mtv_info = SigTv }    -> False
-      MetaTv { mtv_info = TauTv }    -> xopt LangExt.ImpredicativeTypes dflags
-      _other                         -> True
+      MetaTv { mtv_info = TyVarTv }    -> False
+      MetaTv { mtv_info = TauTv }      -> xopt LangExt.ImpredicativeTypes dflags
+      _other                           -> True
           -- We can have non-meta tyvars in given constraints
diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot
index 9af4c27775..295c85eb73 100644
--- a/compiler/typecheck/TcUnify.hs-boot
+++ b/compiler/typecheck/TcUnify.hs-boot
@@ -1,14 +1,15 @@
 module TcUnify where
+
+import GhcPrelude
 import TcType      ( TcTauType )
 import TcRnTypes   ( TcM )
 import TcEvidence  ( TcCoercion )
-import Outputable  ( Outputable )
 import HsExpr      ( HsExpr )
+import HsTypes     ( HsType )
 import HsExtension ( GhcRn )
 
 -- This boot file exists only to tie the knot between
 --              TcUnify and Inst
 
-unifyType :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion
-unifyKind :: Outputable a => Maybe a -> TcTauType -> TcTauType -> TcM TcCoercion
-noThing   :: Maybe (HsExpr GhcRn)
+unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 4f7507745e..dab9f2c308 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -9,29 +9,31 @@ module TcValidity (
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
   ContextKind(..), expectedKindInCtxt,
   checkValidTheta, checkValidFamPats,
-  checkValidInstance, validDerivPred,
-  checkInstTermination, checkTySynRhs,
+  checkValidInstance, checkValidInstHead, validDerivPred,
+  checkTySynRhs,
   ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,
   checkValidTyFamEqn,
   arityErr, badATErr,
-  checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds,
+  checkValidTelescope,
   allDistinctTyVars
   ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Maybes
 
 -- friends:
 import TcUnify    ( tcSubType_NC )
 import TcSimplify ( simplifyAmbiguityCheck )
+import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..) )
 import TyCoRep
 import TcType hiding ( sizeType, sizeTypes )
-import TcMType
+import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )
 import PrelNames
 import Type
 import Coercion
-import Kind
 import CoAxiom
 import Class
 import TyCon
@@ -39,30 +41,30 @@ import TyCon
 -- others:
 import HsSyn            -- HsType
 import TcRnMonad        -- TcType, amongst others
-import TcEnv       ( tcGetInstEnvs )
+import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )
 import FunDeps
-import InstEnv     ( InstMatch, lookupInstEnv )
 import FamInstEnv  ( isDominatedBy, injectiveBranches,
                      InjectivityCheckResult(..) )
 import FamInst     ( makeInjectivityErrors )
 import Name
 import VarEnv
 import VarSet
-import UniqSet
-import Var         ( TyVarBndr(..), mkTyVar )
+import Id          ( idType, idName )
+import Var         ( VarBndr(..), mkTyVar )
 import ErrUtils
 import DynFlags
 import Util
 import ListSetOps
 import SrcLoc
 import Outputable
-import BasicTypes
-import Module
+import Bag         ( emptyBag )
 import Unique      ( mkAlphaTyVarUnique )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
-import Data.List        ( (\\) )
+import Data.Foldable
+import Data.List        ( (\\), nub )
+import qualified Data.List.NonEmpty as NE
 
 {-
 ************************************************************************
@@ -149,7 +151,7 @@ The nested forall is ambiguous.  Originally we called checkAmbiguity
 in the forall case of check_type, but that had two bad consequences:
   * We got two error messages about (Eq b) in a nested forall like this:
        g :: forall a. Eq a => forall b. Eq b => a -> a
-  * If we try to check for ambiguity of an nested forall like
+  * If we try to check for ambiguity of a nested forall like
     (forall a. Eq a => b), the implication constraint doesn't bind
     all the skolems, which results in "No skolem info" in error
     messages (see Trac #10432).
@@ -225,6 +227,7 @@ wantAmbiguityCheck ctxt
   = case ctxt of  -- See Note [When we don't check for ambiguity]
       GhciCtxt     -> False
       TySynCtxt {} -> False
+      TypeAppCtxt  -> False
       _            -> True
 
 checkUserTypeError :: Type -> TcM ()
@@ -269,6 +272,10 @@ In a few places we do not want to check a user-specified type for ambiguity
   from doing an ambiguity check on a type with TyVars in it.  Fixing this
   would not be hard, but let's wait till there's a reason.
 
+* TypeAppCtxt: visible type application
+     f @ty
+  No need to check ty for ambiguity
+
 
 ************************************************************************
 *                                                                      *
@@ -331,6 +338,7 @@ checkValidType ctxt ty
                  TySynCtxt _    -> rank0
 
                  ExprSigCtxt    -> rank1
+                 KindSigCtxt    -> rank1
                  TypeAppCtxt | impred_flag -> ArbitraryRank
                              | otherwise   -> tyConArgMonoType
                     -- Normally, ImpredicativeTypes is handled in check_arg_type,
@@ -347,6 +355,12 @@ checkValidType ctxt ty
                  SpecInstCtxt   -> rank1
                  ThBrackCtxt    -> rank1
                  GhciCtxt       -> ArbitraryRank
+
+                 TyVarBndrKindCtxt _ -> rank0
+                 DataKindCtxt _      -> rank1
+                 TySynKindCtxt _     -> rank1
+                 TyFamResKindCtxt _  -> rank1
+
                  _              -> panic "checkValidType"
                                           -- Can't happen; not used for *user* sigs
 
@@ -372,10 +386,10 @@ checkValidMonoType ty
 
 checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
 checkTySynRhs ctxt ty
-  | returnsConstraintKind actual_kind
+  | tcReturnsConstraintKind actual_kind
   = do { ck <- xoptM LangExt.ConstraintKinds
        ; if ck
-         then  when (isConstraintKind actual_kind)
+         then  when (tcIsConstraintKind actual_kind)
                     (do { dflags <- getDynFlags
                         ; check_pred_ty emptyTidyEnv dflags ctxt ty })
          else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }
@@ -398,12 +412,12 @@ expectedKindInCtxt ThBrackCtxt     = AnythingKind
 expectedKindInCtxt GhciCtxt        = AnythingKind
 -- The types in a 'default' decl can have varying kinds
 -- See Note [Extended defaults]" in TcEnv
-expectedKindInCtxt DefaultDeclCtxt = AnythingKind
-expectedKindInCtxt TypeAppCtxt     = AnythingKind
-expectedKindInCtxt (ForSigCtxt _)  = TheKind liftedTypeKind
-expectedKindInCtxt InstDeclCtxt    = TheKind constraintKind
-expectedKindInCtxt SpecInstCtxt    = TheKind constraintKind
-expectedKindInCtxt _               = OpenKind
+expectedKindInCtxt DefaultDeclCtxt     = AnythingKind
+expectedKindInCtxt TypeAppCtxt         = AnythingKind
+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
+expectedKindInCtxt _                   = OpenKind
 
 {-
 Note [Higher rank types]
@@ -430,7 +444,8 @@ rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank
 rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types")
 tyConArgMonoType   = MonoType (text "GHC doesn't yet support impredicative polymorphism")
 synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")
-constraintMonoType = MonoType (text "A constraint must be a monotype")
+constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"
+                                    , text "Perhaps you intended to use QuantifiedConstraints" ])
 
 funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result
 funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
@@ -450,7 +465,7 @@ check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM ()
 -- Rank 0 means no for-alls anywhere
 
 check_type env ctxt rank ty
-  | not (null tvs && null theta)
+  | not (null tvbs && null theta)
   = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))
         ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)
                 -- Reject e.g. (Maybe (?x::Int => Int)),
@@ -461,14 +476,18 @@ check_type env ctxt rank ty
                 -- but not   type T = ?x::Int
 
         ; check_type env' ctxt rank tau      -- Allow foralls to right of arrow
+
         ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))
                    (forAllEscapeErr env' ty tau_kind)
         }
   where
-    (tvs, theta, tau) = tcSplitSigmaTy ty
-    tau_kind          = typeKind tau
-    (env', _)         = tidyTyCoVarBndrs env tvs
+    (tvbs, phi)  = tcSplitForAllVarBndrs ty
+    (theta, tau) = tcSplitPhiTy phi
 
+    tvs          = binderVars tvbs
+    (env', _)    = tidyVarBndrs env tvs
+
+    tau_kind              = typeKind tau
     phi_kind | null theta = tau_kind
              | otherwise  = liftedTypeKind
         -- If there are any constraints, the kind is *. (#11405)
@@ -482,7 +501,7 @@ check_type env ctxt rank (FunTy arg_ty res_ty)
     (arg_rank, res_rank) = funArgResRank rank
 
 check_type env ctxt rank (AppTy ty1 ty2)
-  = do  { check_arg_type env ctxt rank ty1
+  = do  { check_type env ctxt rank ty1
         ; check_arg_type env ctxt rank ty2 }
 
 check_type env ctxt rank ty@(TyConApp tc tys)
@@ -606,7 +625,10 @@ forAllEscapeErr env ty tau_kind
                  , text "of kind:" <+> ppr_tidy env tau_kind ]) )
 
 ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
-ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty])
+ubxArgTyErr env ty
+  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"
+                      , ppr_tidy env ty ]
+                , text "Perhaps you intended to use UnboxedTuples" ] )
 
 {-
 Note [Liberal type synonyms]
@@ -660,9 +682,9 @@ applying the instance decl would show up two uses of ?x.  Trac #8912.
 checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
 -- Assumes argument is fully zonked
 checkValidTheta ctxt theta
-  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
-       ; addErrCtxtM (checkThetaCtxt ctxt theta) $
-         check_valid_theta env ctxt theta }
+  = addErrCtxtM (checkThetaCtxt ctxt theta) $
+    do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
+       ; check_valid_theta env ctxt theta }
 
 -------------------------
 check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM ()
@@ -709,8 +731,13 @@ check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
 -- Check the validity of a predicate in a signature
 -- See Note [Validity checking for constraints]
 check_pred_ty env dflags ctxt pred
-  = do { check_type env SigmaCtxt constraintMonoType pred
+  = do { check_type env SigmaCtxt rank pred
        ; check_pred_help False env dflags ctxt pred }
+  where
+    rank | xopt LangExt.QuantifiedConstraints dflags
+         = ArbitraryRank
+         | otherwise
+         = constraintMonoType
 
 check_pred_help :: Bool    -- True <=> under a type synonym
                 -> TidyEnv
@@ -720,29 +747,52 @@ check_pred_help under_syn env dflags ctxt pred
   | Just pred' <- tcView pred  -- Switch on under_syn when going under a
                                  -- synonym (Trac #9838, yuk)
   = check_pred_help True env dflags ctxt pred'
-  | otherwise
-  = case splitTyConApp_maybe pred of
-      Just (tc, tys)
-        | isTupleTyCon tc
-        -> check_tuple_pred under_syn env dflags ctxt pred tys
-           -- NB: this equality check must come first, because (~) is a class,
-           -- too.
-        | tc `hasKey` heqTyConKey ||
-          tc `hasKey` eqTyConKey ||
-          tc `hasKey` eqPrimTyConKey
-        -> check_eq_pred env dflags pred tc tys
-        | Just cls <- tyConClass_maybe tc
-        -> check_class_pred env dflags ctxt pred cls tys  -- Includes Coercible
-      _ -> check_irred_pred under_syn env dflags ctxt pred
-
-check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()
-check_eq_pred env dflags pred tc tys
+
+  | otherwise  -- A bit like classifyPredType, but not the same
+               -- E.g. we treat (~) like (~#); and we look inside tuples
+  = case classifyPredType pred of
+      ClassPred cls tys
+        | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys
+        | otherwise           -> check_class_pred env dflags ctxt pred cls tys
+
+      EqPred NomEq _ _  -> -- a ~# b
+                           check_eq_pred env dflags pred
+
+      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get
+                           -- f :: (a ~R# b) => blha
+                           -- And we want to treat that like (Coercible a b)
+                           -- We should probably check argument shapes, but we
+                           -- didn't do so before, so I'm leaving it for now
+                           return ()
+
+      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head
+      IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred
+
+check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()
+check_eq_pred env dflags pred
   =         -- Equational constraints are valid in all contexts if type
             -- families are permitted
-    do { checkTc (tys `lengthIs` tyConArity tc) (tyConArityErr tc tys)
-       ; checkTcM (xopt LangExt.TypeFamilies dflags
-                   || xopt LangExt.GADTs dflags)
-                  (eqPredTyErr env pred) }
+    checkTcM (xopt LangExt.TypeFamilies dflags
+              || xopt LangExt.GADTs dflags)
+             (eqPredTyErr env pred)
+
+check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> ThetaType -> PredType -> TcM ()
+check_quant_pred env dflags _ctxt pred theta head_pred
+  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $
+    do { -- Check the instance head
+         case classifyPredType head_pred of
+            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys
+                                 -- SigmaCtxt tells checkValidInstHead that
+                                 -- this is the head of a quantified constraint
+            IrredPred {}      | hasTyVarHead head_pred
+                              -> return ()
+            _                 -> failWithTcM (badQuantHeadErr env pred)
+
+         -- Check for termination
+       ; unless (xopt LangExt.UndecidableInstances dflags) $
+         checkInstTermination theta head_pred
+    }
 
 check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
 check_tuple_pred under_syn env dflags ctxt pred ts
@@ -802,16 +852,21 @@ This will cause the constraint simplifier to loop because every time we canonica
 solved to add+canonicalise another (Foo a) constraint.  -}
 
 -------------------------
-check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
+check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> Class -> [TcType] -> TcM ()
 check_class_pred env dflags ctxt pred cls tys
+  |  cls `hasKey` heqTyConKey   -- (~) and (~~) are classified as classes,
+  || cls `hasKey` eqTyConKey    -- but here we want to treat them as equalities
+  = -- pprTrace "check_class" (ppr cls) $
+    check_eq_pred env dflags pred
+
   | isIPClass cls
   = do { check_arity
        ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
 
-  | otherwise
+  | otherwise     -- Includes Coercible
   = do { check_arity
-       ; warn_simp <- woptM Opt_WarnSimplifiableClassConstraints
-       ; when warn_simp check_simplifiable_class_constraint
+       ; checkSimplifiableClassConstraint env dflags ctxt cls tys
        ; checkTcM arg_tys_ok (predTyVarErr env pred) }
   where
     check_arity = checkTc (tys `lengthIs` classArity cls)
@@ -822,32 +877,53 @@ check_class_pred env dflags ctxt pred cls tys
     undecidable_ok    = xopt LangExt.UndecidableInstances dflags
     arg_tys_ok = case ctxt of
         SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
-        InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
+        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
                                 -- Further checks on head and theta
                                 -- in checkInstTermination
-        _            -> checkValidClsArgs flexible_contexts cls tys
-
-    -- See Note [Simplifiable given constraints]
-    check_simplifiable_class_constraint
-       | xopt LangExt.MonoLocalBinds dflags
-       = return ()
-       | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
-       = return ()               -- of a data type declaration
-       | otherwise
-       = do { envs <- tcGetInstEnvs
-            ; case lookupInstEnv False envs cls tys of
-                 ([m], [], _) -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)
-                                           (simplifiable_constraint_warn m)
-                 _ -> return () }
-
-    simplifiable_constraint_warn :: InstMatch -> SDoc
-    simplifiable_constraint_warn (match, _)
-     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)))
-                 2 (text "matches an instance declaration")
-            , ppr match
+        _               -> checkValidClsArgs flexible_contexts cls tys
+
+checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
+                                 -> Class -> [TcType] -> TcM ()
+-- See Note [Simplifiable given constraints]
+checkSimplifiableClassConstraint env dflags ctxt cls tys
+  | not (wopt Opt_WarnSimplifiableClassConstraints dflags)
+  = return ()
+  | xopt LangExt.MonoLocalBinds dflags
+  = return ()
+
+  | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
+  = return ()               -- of a data type declaration
+
+  | cls `hasKey` coercibleTyConKey
+  = return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK
+                -- matchGlobalInst will reply "yes" because we can reduce
+                -- (Coercible a b) to (a ~R# b)
+
+  | otherwise
+  = do { result <- matchGlobalInst dflags False cls tys
+       ; case result of
+           OneInst { cir_what = what }
+              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)
+                                   (simplifiable_constraint_warn what)
+           _          -> return () }
+  where
+    pred = mkClassPred cls tys
+
+    simplifiable_constraint_warn :: InstanceWhat -> SDoc
+    simplifiable_constraint_warn what
+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))
+                    <+> text "matches")
+                 2 (ppr_what what)
             , hang (text "This makes type inference for inner bindings fragile;")
                  2 (text "either use MonoLocalBinds, or simplify it using the instance") ]
 
+    ppr_what BuiltinInstance = text "a built-in instance"
+    ppr_what LocalInstance   = text "a locally-quantified instance"
+    ppr_what (TopLevInstance { iw_dfun_id = dfun })
+      = hang (text "instance" <+> pprSigmaType (idType dfun))
+           2 (text "--" <+> pprDefinedAt (idName dfun))
+
+
 {- Note [Simplifiable given constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A type signature like
@@ -903,11 +979,17 @@ okIPCtxt (PatSynCtxt {})        = True
 okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int
                                          -- Trac #11466
 
-okIPCtxt (ClassSCCtxt {})  = False
-okIPCtxt (InstDeclCtxt {}) = False
-okIPCtxt (SpecInstCtxt {}) = False
-okIPCtxt (RuleSigCtxt {})  = False
-okIPCtxt DefaultDeclCtxt   = False
+okIPCtxt (KindSigCtxt {})       = False
+okIPCtxt (ClassSCCtxt {})       = False
+okIPCtxt (InstDeclCtxt {})      = False
+okIPCtxt (SpecInstCtxt {})      = False
+okIPCtxt (RuleSigCtxt {})       = False
+okIPCtxt DefaultDeclCtxt        = False
+okIPCtxt DerivClauseCtxt        = False
+okIPCtxt (TyVarBndrKindCtxt {}) = False
+okIPCtxt (DataKindCtxt {})      = False
+okIPCtxt (TySynKindCtxt {})     = False
+okIPCtxt (TyFamResKindCtxt {})  = False
 
 {-
 Note [Kind polymorphic type classes]
@@ -936,7 +1018,12 @@ checkThetaCtxt ctxt theta env
            , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
                   , text "While checking" <+> pprUserTypeCtxt ctxt ] )
 
-eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+eqPredTyErr, predTupleErr, predIrredErr,
+   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badQuantHeadErr env pred
+  = ( env
+    , hang (text "Quantified predicate must have a class or type variable head:")
+         2 (ppr_tidy env pred) )
 eqPredTyErr  env pred
   = ( env
     , text "Illegal equational constraint" <+> ppr_tidy env pred $$
@@ -973,13 +1060,13 @@ constraintSynErr env kind
     , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
          2 (parens constraintKindsMsg) )
 
-dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc)
+dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
 dupPredWarn env dups
   = ( env
     , text "Duplicate constraint" <> plural primaryDups <> text ":"
       <+> pprWithCommas (ppr_tidy env) primaryDups )
   where
-    primaryDups = map head dups
+    primaryDups = map NE.head dups
 
 tyConArityErr :: TyCon -> [TcType] -> SDoc
 -- For type-constructor arity errors, be careful to report
@@ -1026,35 +1113,86 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
 checkValidInstHead ctxt clas cls_args
-  = do { dflags <- getDynFlags
+  = do { dflags   <- getDynFlags
+       ; is_boot  <- tcIsHsBootOrSig
+       ; check_valid_inst_head dflags is_boot ctxt clas cls_args }
+
+check_valid_inst_head :: DynFlags -> Bool
+                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()
+-- Wow!  There are a surprising number of ad-hoc special cases here.
+check_valid_inst_head dflags is_boot ctxt clas cls_args
+
+  -- If not in an hs-boot file, abstract classes cannot have instances
+  | isAbstractClass clas
+  , not is_boot
+  = failWithTc abstract_class_msg
+
+  -- For Typeable, don't complain about instances for
+  -- standalone deriving; they are no-ops, and we warn about
+  -- it in TcDeriv.deriveStandalone
+  | clas_nm == typeableClassName
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- Handwritten instances of KnownNat/KnownSymbol class
+  -- are always forbidden (#12837)
+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- For the most part we don't allow
+  -- instances for (~), (~~), or Coercible;
+  -- but we DO want to allow them in quantified constraints:
+  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]
+  , not quantified_constraint
+  = failWithTc rejected_class_msg
+
+  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
+  | clas_nm `elem` genericClassNames
+  , hand_written_bindings
+  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err
+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+
+  | clas_nm == hasFieldClassName
+  = checkHasFieldInst clas cls_args
+
+  | isCTupleClass clas
+  = failWithTc tuple_class_msg
+
+  -- Check language restrictions on the args to the class
+  | check_h98_arg_shape
+  , Just msg <- mb_ty_args_msg
+  = failWithTc (instTypeErr clas cls_args msg)
 
-       ; mod <- getModule
-       ; checkTc (getUnique clas `notElem` abstractClassKeys ||
-                  nameModule (getName clas) == mod)
-                 (instTypeErr clas cls_args abstract_class_msg)
-
-       ; when (clas `hasKey` hasFieldClassNameKey) $
-             checkHasFieldInst clas cls_args
-
-           -- Check language restrictions;
-           -- but not for SPECIALISE instance pragmas
-       ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
-       ; unless spec_inst_prag $
-         do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
-                       all tcInstHeadTyNotSynonym ty_args)
-                 (instTypeErr clas cls_args head_type_synonym_msg)
-            ; checkTc (xopt LangExt.FlexibleInstances dflags ||
-                       all tcInstHeadTyAppAllTyVars ty_args)
-                 (instTypeErr clas cls_args head_type_args_tyvars_msg)
-            ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
-                       lengthIs ty_args 1 ||  -- Only count type arguments
-                       (xopt LangExt.NullaryTypeClasses dflags &&
-                        null ty_args))
-                 (instTypeErr clas cls_args head_one_type_msg) }
-
-       ; mapM_ checkValidTypePat ty_args }
+  | otherwise
+  = checkValidTypePats (classTyCon clas) cls_args
   where
-    spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
+    clas_nm = getName clas
+    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
+
+    hand_written_bindings
+        = case ctxt of
+            InstDeclCtxt stand_alone -> not stand_alone
+            SpecInstCtxt             -> False
+            DerivClauseCtxt          -> False
+            _                        -> True
+
+    check_h98_arg_shape = case ctxt of
+                            SpecInstCtxt    -> False
+                            DerivClauseCtxt -> False
+                            SigmaCtxt       -> False
+                            _               -> True
+        -- SigmaCtxt: once we are in quantified-constraint land, we
+        -- aren't so picky about enforcing H98-language restrictions
+        -- E.g. we want to allow a head like Coercible (m a) (m b)
+
+
+    -- When we are looking at the head of a quantified constraint,
+    -- check_quant_pred sets ctxt to SigmaCtxt
+    quantified_constraint = case ctxt of
+                              SigmaCtxt -> True
+                              _         -> False
 
     head_type_synonym_msg = parens (
                 text "All instance types must be of the form (T t1 ... tn)" $$
@@ -1067,12 +1205,35 @@ checkValidInstHead ctxt clas cls_args
                 text "and each type variable appears at most once in the instance head.",
                 text "Use FlexibleInstances if you want to disable this."])
 
-    head_one_type_msg = parens (
-                text "Only one type can be given in an instance head." $$
-                text "Use MultiParamTypeClasses if you want to allow more, or zero.")
+    head_one_type_msg = parens $
+                        text "Only one type can be given in an instance head." $$
+                        text "Use MultiParamTypeClasses if you want to allow more, or zero."
+
+    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)
+                         <+> text "does not support user-specified instances"
+    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"
+
+    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")
+
+    abstract_class_msg = text "Cannot define instance for abstract class"
+                         <+> quotes (ppr clas_nm)
 
-    abstract_class_msg =
-                text "Manual instances of this class are not permitted."
+    mb_ty_args_msg
+      | not (xopt LangExt.TypeSynonymInstances dflags)
+      , not (all tcInstHeadTyNotSynonym ty_args)
+      = Just head_type_synonym_msg
+
+      | not (xopt LangExt.FlexibleInstances dflags)
+      , not (all tcInstHeadTyAppAllTyVars ty_args)
+      = Just head_type_args_tyvars_msg
+
+      | length ty_args /= 1
+      , not (xopt LangExt.MultiParamTypeClasses dflags)
+      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
+      = Just head_one_type_msg
+
+      | otherwise
+      = Nothing
 
 tcInstHeadTyNotSynonym :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
@@ -1086,12 +1247,13 @@ tcInstHeadTyNotSynonym ty
 
 tcInstHeadTyAppAllTyVars :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
--- These must be a constructor applied to type variable arguments.
+-- These must be a constructor applied to type variable arguments
+-- or a type-level literal.
 -- But we allow kind instantiations.
 tcInstHeadTyAppAllTyVars ty
   | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)
   = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds
-
+  | LitTy _ <- ty = True  -- accept type literals (Trac #13833)
   | otherwise
   = False
   where
@@ -1105,7 +1267,7 @@ dropCasts :: Type -> Type
 -- See Note [Casts during validity checking]
 -- This function can turn a well-kinded type into an ill-kinded
 -- one, so I've kept it local to this module
--- To consider: drop only UnivCo(HoleProv) casts
+-- To consider: drop only HoleCo casts
 dropCasts (CastTy ty _)     = dropCasts ty
 dropCasts (AppTy t1 t2)     = mkAppTy (dropCasts t1) (dropCasts t2)
 dropCasts (FunTy t1 t2)     = mkFunTy (dropCasts t1) (dropCasts t2)
@@ -1116,12 +1278,6 @@ dropCasts ty                = ty  -- LitTy, TyVarTy, CoercionTy
 dropCastsB :: TyVarBinder -> TyVarBinder
 dropCastsB b = b   -- Don't bother in the kind of a forall
 
-abstractClassKeys :: [Unique]
-abstractClassKeys = [ heqTyConKey
-                    , eqTyConKey
-                    , coercibleTyConKey
-                    ] -- See Note [Equality class instances]
-
 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
 instTypeErr cls tys msg
   = hang (hang (text "Illegal instance declaration for")
@@ -1201,7 +1357,7 @@ It checks for three things
     might be applications thus (f (g x)).
 
     Note that tys only includes the visible arguments of the class type
-    constructor. Including the non-vivisble arguments can cause the following,
+    constructor. Including the non-visible arguments can cause the following,
     perfectly valid instance to be rejected:
        class Category (cat :: k -> k -> *) where ...
        newtype T (c :: * -> * -> *) a b = MkT (c a b)
@@ -1278,7 +1434,8 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type
                    -> TcM ([TyVar], ThetaType, Class, [Type])
 checkValidInstance ctxt hs_type ty
   | not is_tc_app
-  = failWithTc (text "Instance head is not headed by a class")
+  = failWithTc (hang (text "Instance head is not headed by a class:")
+                   2 ( ppr tau))
 
   | isNothing mb_cls
   = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)
@@ -1288,9 +1445,13 @@ checkValidInstance ctxt hs_type ty
   = failWithTc (text "Arity mis-match in instance head")
 
   | otherwise
-  = do  { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
+  = do  { setSrcSpan head_loc $
+          checkValidInstHead ctxt clas inst_tys
+
         ; traceTc "checkValidInstance {" (ppr ty)
-        ; checkValidTheta ctxt theta
+
+        ; env0 <- tcInitTidyEnv
+        ; check_valid_theta env0 ctxt theta
 
         -- The Termination and Coverate Conditions
         -- Check that instance inference will terminate (if we care)
@@ -1305,7 +1466,7 @@ checkValidInstance ctxt hs_type ty
         ; undecidable_ok <- xoptM LangExt.UndecidableInstances
         ; if undecidable_ok
           then checkAmbiguity ctxt ty
-          else checkInstTermination inst_tys theta
+          else checkInstTermination theta tau
 
         ; traceTc "cvi 2" (ppr ty)
 
@@ -1347,63 +1508,86 @@ The underlying idea is that
     context has fewer type constructors than the head.
 -}
 
-checkInstTermination :: [TcType] -> ThetaType -> TcM ()
+checkInstTermination :: ThetaType -> TcPredType -> TcM ()
 -- See Note [Paterson conditions]
-checkInstTermination tys theta
-  = check_preds theta
+checkInstTermination theta head_pred
+  = check_preds emptyVarSet theta
   where
-   head_fvs  = fvTypes tys
-   head_size = sizeTypes tys
+   head_fvs  = fvType head_pred
+   head_size = sizeType head_pred
 
-   check_preds :: [PredType] -> TcM ()
-   check_preds preds = mapM_ check preds
+   check_preds :: VarSet -> [PredType] -> TcM ()
+   check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds
 
-   check :: PredType -> TcM ()
-   check pred
+   check :: VarSet -> PredType -> TcM ()
+   check foralld_tvs pred
      = case classifyPredType pred of
          EqPred {}    -> return ()  -- See Trac #4200.
-         IrredPred {} -> check2 pred (sizeType pred)
+         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)
          ClassPred cls tys
            | isTerminatingClass cls
            -> return ()
 
            | isCTupleClass cls  -- Look inside tuple predicates; Trac #8359
-           -> check_preds tys
-
-           | otherwise
-           -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys)
-                       -- Other ClassPreds
+           -> check_preds foralld_tvs tys
 
-   check2 pred pred_size
-     | not (null bad_tvs)     = addErrTc (noMoreMsg bad_tvs what)
-     | pred_size >= head_size = addErrTc (smallerMsg what)
+           | otherwise          -- Other ClassPreds
+           -> check2 foralld_tvs pred bogus_size
+           where
+              bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys)
+                               -- See Note [Invisible arguments and termination]
+
+         ForAllPred tvs _ head_pred'
+           -> check (foralld_tvs `extendVarSetList` binderVars tvs) head_pred'
+              -- Termination of the quantified predicate itself is checked
+              -- when the predicates are individually checked for validity
+
+   check2 foralld_tvs pred pred_size
+     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))
+     | not (isTyFamFree pred) = failWithTc (nestedMsg what)
+     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))
      | otherwise              = return ()
+     -- isTyFamFree: see Note [Type families in instance contexts]
      where
         what    = text "constraint" <+> quotes (ppr pred)
-        bad_tvs = fvType pred \\ head_fvs
+        bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred)
+                  \\ head_fvs
 
-smallerMsg :: SDoc -> SDoc
-smallerMsg what
+smallerMsg :: SDoc -> SDoc -> SDoc
+smallerMsg what inst_head
   = vcat [ hang (text "The" <+> what)
-              2 (text "is no smaller than the instance head")
+              2 (sep [ text "is no smaller than"
+                     , text "the instance head" <+> quotes inst_head ])
          , parens undecidableMsg ]
 
-noMoreMsg :: [TcTyVar] -> SDoc -> SDoc
-noMoreMsg tvs what
-  = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)
+noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
+noMoreMsg tvs what inst_head
+  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)
                 <+> occurs <+> text "more often")
               2 (sep [ text "in the" <+> what
-                     , text "than in the instance head" ])
+                     , text "than in the instance head" <+> quotes inst_head ])
          , parens undecidableMsg ]
   where
-   occurs = if isSingleton tvs then text "occurs"
+   tvs1   = nub tvs
+   occurs = if isSingleton tvs1 then text "occurs"
                                else text "occur"
 
 undecidableMsg, constraintKindsMsg :: SDoc
 undecidableMsg     = text "Use UndecidableInstances to permit this"
 constraintKindsMsg = text "Use ConstraintKinds to permit this"
 
-{-
+{- Note [Type families in instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Are these OK?
+  type family F a
+  instance F a    => C (Maybe [a]) where ...
+  intance C (F a) => C [[[a]]]     where ...
+
+No: the type family in the instance head might blow up to an
+arbitrarily large type, depending on how 'a' is instantiated.
+So we require UndecidableInstances if we have a type family
+in the instance head.  Trac #15172.
+
 Note [Associated type instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We allow this:
@@ -1515,6 +1699,20 @@ Here the instance is kind-indexed and really looks like
       type F (k->k) (b::k->k) = Int
 But if the 'b' didn't scope, we would make F's instance too
 poly-kinded.
+
+Note [Invisible arguments and termination]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking the ​Paterson conditions for termination an instance
+declaration, we check for the number of "constructors and variables"
+in the instance head and constraints. Question: Do we look at
+
+ * All the arguments, visible or invisible?
+ * Just the visible arguments?
+
+I think both will ensure termination, provided we are consistent.
+Currently we are /not/ consistent, which is really a bug.  It's
+described in Trac #15177, which contains a number of examples.
+The suspicious bits are the calls to filterOutInvisibleTypes.
 -}
 
 -- | Extra information about the parent instance declaration, needed
@@ -1540,14 +1738,16 @@ type AssocInstArgShape = (Maybe Type, Type)
 checkConsistentFamInst
                :: Maybe ClsInstInfo
                -> TyCon              -- ^ Family tycon
-               -> [TyVar]            -- ^ Type variables of the family instance
                -> [Type]             -- ^ Type patterns from instance
+               -> SDoc               -- ^ pretty-printed user-written instance head
                -> TcM ()
 -- See Note [Checking consistent instantiation]
 
 checkConsistentFamInst Nothing _ _ _ = return ()
-checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc _at_tvs at_tys
+checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc at_tys pp_hs_pats
   = do { -- Check that the associated type indeed comes from this class
+         -- See [Mismatched class methods and associated type families]
+         -- in TcInstDecls.
          checkTc (Just clas == tyConAssoc_maybe fam_tc)
                  (badATErr (className clas) (tyConName fam_tc))
 
@@ -1555,8 +1755,8 @@ checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc _at_tvs at_tys
        ; checkTc (all check_arg type_shapes)   pp_wrong_at_arg
 
        -- And now kind args
-       ; checkTc (all check_arg kind_shapes)
-                 (pp_wrong_at_arg $$ ppSuggestExplicitKinds)
+       ; checkTcM (all check_arg kind_shapes)
+                  (tidy_env2, pp_wrong_at_arg $$ ppSuggestExplicitKinds)
 
        ; traceTc "cfi" (vcat [ ppr inst_tvs
                              , ppr arg_shapes
@@ -1579,13 +1779,22 @@ checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc _at_tvs at_tys
 
     pp_exp_act
       = vcat [ text "Expected:" <+> ppr (mkTyConApp fam_tc expected_args)
-             , text "  Actual:" <+> ppr (mkTyConApp fam_tc at_tys)
+             , text "  Actual:" <+> pp_hs_pats
              , sdocWithDynFlags $ \dflags ->
                ppWhen (has_poly_args dflags) $
                vcat [ text "where the `<tv>' arguments are type variables,"
                     , text "distinct from each other and from the instance variables" ] ]
 
-    expected_args = [ exp_ty `orElse` mk_tv at_ty | (exp_ty, at_ty) <- arg_shapes ]
+    -- We need to tidy, since it's possible that expected_args will contain
+    -- inferred kind variables with names identical to those in at_tys. If we
+    -- don't, we'll end up with horrible messages like this one (#13972):
+    --
+    --   Expected: T (a -> Either a b)
+    --     Actual: T (a -> Either a b)
+    (tidy_env1, _) = tidyOpenTypes emptyTidyEnv at_tys
+    (tidy_env2, expected_args)
+      = tidyOpenTypes tidy_env1 [ exp_ty `orElse` mk_tv at_ty
+                                | (exp_ty, at_ty) <- arg_shapes ]
     mk_tv at_ty   = mkTyVarTy (mkTyVar tv_name (typeKind at_ty))
     tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "<tv>") noSrcSpan
 
@@ -1614,7 +1823,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
        ; foldlM_ check_branch_compat [] branch_list }
   where
     branch_list = fromBranches branches
-    injectivity = familyTyConInjectivityInfo fam_tc
+    injectivity = tyConInjectivityInfo fam_tc
 
     check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order
                         -> CoAxBranch      -- current branch
@@ -1638,7 +1847,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
     check_injectivity prev_branches cur_branch
       | Injective inj <- injectivity
       = do { let conflicts =
-                     fst $ foldl (gather_conflicts inj prev_branches cur_branch)
+                     fst $ foldl' (gather_conflicts inj prev_branches cur_branch)
                                  ([], 0) prev_branches
            ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
                    (makeInjectivityErrors ax cur_branch inj conflicts) }
@@ -1669,7 +1878,9 @@ checkValidCoAxBranch mb_clsinfo fam_tc
                     (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
                                 , cab_lhs = typats
                                 , cab_rhs = rhs, cab_loc = loc })
-  = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
+  = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc
+  where
+    pp_lhs = ppr (mkTyConApp fam_tc typats)
 
 -- | Do validity checks on a type family equation, including consistency
 -- with any enclosing class instance head, termination, and lack of
@@ -1680,11 +1891,12 @@ checkValidTyFamEqn :: Maybe ClsInstInfo
                    -> [CoVar] -- ^ bound covars in the equation
                    -> [Type]  -- ^ type patterns
                    -> Type    -- ^ rhs
+                   -> SDoc    -- ^ user-written LHS
                    -> SrcSpan
                    -> TcM ()
-checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
+checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc
   = setSrcSpan loc $
-    do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats
+    do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats [] pp_lhs
 
          -- The argument patterns, and RHS, are all boxed tau types
          -- E.g  Reject type family F (a :: k1) :: k2
@@ -1697,32 +1909,43 @@ checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
 
          -- We have a decidable instance unless otherwise permitted
        ; undecidable_ok <- xoptM LangExt.UndecidableInstances
+       ; traceTc "checkVTFE" (pp_lhs $$ ppr rhs $$ ppr (tcTyFamInsts rhs))
        ; unless undecidable_ok $
-           mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) }
+           mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }
 
 -- Make sure that each type family application is
 --   (1) strictly smaller than the lhs,
 --   (2) mentions no type variable more often than the lhs, and
 --   (3) does not contain any further type family instances.
 --
-checkFamInstRhs :: [Type]                  -- lhs
-                -> [(TyCon, [Type])]       -- type family instances
+checkFamInstRhs :: TyCon -> [Type]         -- LHS
+                -> [(TyCon, [Type])]       -- type family calls in RHS
                 -> [MsgDoc]
-checkFamInstRhs lhsTys famInsts
+checkFamInstRhs lhs_tc lhs_tys famInsts
   = mapMaybe check famInsts
   where
-   size = sizeTypes lhsTys
-   fvs  = fvTypes lhsTys
+   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys
+   inst_head = pprType (TyConApp lhs_tc lhs_tys)
+   lhs_fvs   = fvTypes lhs_tys
    check (tc, tys)
       | not (all isTyFamFree tys) = Just (nestedMsg what)
-      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what)
-      | size <= sizeTypes tys     = Just (smallerMsg what)
+      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)
+      | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)
       | otherwise                 = Nothing
       where
-        what    = text "type family application" <+> quotes (pprType (TyConApp tc tys))
-        bad_tvs = fvTypes tys \\ fvs
-
-checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM ()
+        what = text "type family application"
+               <+> quotes (pprType (TyConApp tc tys))
+        fam_app_size = sizeTyConAppArgs tc tys
+        bad_tvs      = fvTypes tys \\ lhs_fvs
+                       -- The (\\) is list difference; e.g.
+                       --   [a,b,a,a] \\ [a,a] = [b,a]
+                       -- So we are counting repetitions
+
+checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar]
+                  -> [Type]   -- ^ patterns the user wrote
+                  -> [Type]   -- ^ "extra" patterns from a data instance kind sig
+                  -> SDoc     -- ^ pretty-printed user-written instance head
+                  -> TcM ()
 -- Patterns in a 'type instance' or 'data instance' decl should
 -- a) contain no type family applications
 --    (vanilla synonyms are fine, though)
@@ -1730,66 +1953,63 @@ checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar] -> [Type]
 --    e.g. we disallow (Trac #7536)
 --         type T a = Int
 --         type instance F (T a) = a
--- c) Have the right number of patterns
--- d) For associated types, are consistently instantiated
-checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats
-  = do { -- A family instance must have exactly the same number of type
-         -- parameters as the family declaration.  You can't write
-         --     type family F a :: * -> *
-         --     type instance F Int y = y
-         -- because then the type (F Int) would be like (\y.y)
-         checkTc (ty_pats `lengthIs` fam_arity) $
-           wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs)
-             -- report only explicit arguments
-
-       ; mapM_ checkValidTypePat ty_pats
-
-       ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs)
-       ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats)
+-- c) For associated types, are consistently instantiated
+checkValidFamPats mb_clsinfo fam_tc tvs cvs user_ty_pats extra_ty_pats pp_hs_pats
+  = do { checkValidTypePats fam_tc user_ty_pats
+
+       ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes user_ty_pats)
+                                      (tvs ++ cvs)
+       ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs user_ty_pats)
 
          -- Check that type patterns match the class instance head
-       ; checkConsistentFamInst mb_clsinfo fam_tc tvs ty_pats }
+       ; checkConsistentFamInst mb_clsinfo fam_tc (user_ty_pats `chkAppend` extra_ty_pats) pp_hs_pats }
+
+-- | Checks for occurrences of type families in class instances and type/data
+-- family instances.
+checkValidTypePats :: TyCon -> [Type] -> TcM ()
+checkValidTypePats tc pat_ty_args =
+  traverse_ (check_valid_type_pat False) invis_ty_args *>
+  traverse_ (check_valid_type_pat True)  vis_ty_args
   where
-     fam_arity = tyConArity fam_tc
-     fam_bndrs = tyConBinders fam_tc
-
-
-checkValidTypePat :: Type -> TcM ()
--- Used for type patterns in class instances,
--- and in type/data family instances
-checkValidTypePat pat_ty
-  = do { -- Check that pat_ty is a monotype
-         checkValidMonoType pat_ty
-             -- One could imagine generalising to allow
-             --      instance C (forall a. a->a)
-             -- but we don't know what all the consequences might be
-
-          -- Ensure that no type family instances occur a type pattern
-       ; checkTc (isTyFamFree pat_ty) $
-         tyFamInstIllegalErr pat_ty }
-
-isTyFamFree :: Type -> Bool
--- ^ Check that a type does not contain any type family applications.
-isTyFamFree = null . tcTyFamInsts
+    (invis_ty_args, vis_ty_args) = partitionInvisibleTypes tc pat_ty_args
+    inst_ty = mkTyConApp tc pat_ty_args
+
+    check_valid_type_pat
+      :: Bool -- True if this is an /visible/ argument to the TyCon.
+      -> Type -> TcM ()
+    -- Used for type patterns in class instances,
+    -- and in type/data family instances
+    check_valid_type_pat vis_arg pat_ty
+      = do { -- Check that pat_ty is a monotype
+             checkValidMonoType pat_ty
+                 -- One could imagine generalising to allow
+                 --      instance C (forall a. a->a)
+                 -- but we don't know what all the consequences might be
+
+              -- Ensure that no type family instances occur a type pattern
+           ; case tcTyFamInsts pat_ty of
+               [] -> pure ()
+               ((tf_tc, tf_args):_) ->
+                 failWithTc $
+                 ty_fam_inst_illegal_err vis_arg (mkTyConApp tf_tc tf_args) }
+
+    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
+    ty_fam_inst_illegal_err vis_arg ty
+      = sdocWithDynFlags $ \dflags ->
+        hang (text "Illegal type synonym family application"
+                <+> quotes (ppr ty) <+> text "in instance" <>
+             colon) 2 $
+          vcat [ ppr inst_ty
+               , ppUnless (vis_arg || gopt Opt_PrintExplicitKinds dflags) $
+                 text "Use -fprint-explicit-kinds to see the kind arguments" ]
 
 -- Error messages
 
-wrongNumberOfParmsErr :: Arity -> SDoc
-wrongNumberOfParmsErr exp_arity
-  = text "Number of parameters must match family declaration; expected"
-    <+> ppr exp_arity
-
 inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
 inaccessibleCoAxBranch fi_ax cur_branch
   = text "Type family instance equation is overlapped:" $$
     nest 2 (pprCoAxBranch fi_ax cur_branch)
 
-tyFamInstIllegalErr :: Type -> SDoc
-tyFamInstIllegalErr ty
-  = hang (text "Illegal type synonym family application in instance" <>
-         colon) 2 $
-      ppr ty
-
 nestedMsg :: SDoc -> SDoc
 nestedMsg what
   = sep [ text "Illegal nested" <+> what
@@ -1831,23 +2051,16 @@ this is bogus. (We could probably figure out to put b between a and c.
 But I think this is doing users a disservice, in the long run.)
 (Testcase: dependent/should_fail/BadTelescope4)
 
-3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> ()
-
-This is a straightforward skolem escape. Note that a and b need to have
-the same kind.
-(Testcase: polykinds/T11142)
+To catch these errors, we call checkValidTelescope during kind-checking
+datatype declarations. This must be done *before* kind-generalization,
+because kind-generalization might observe, say, T1, see that k is free
+in a's kind, and generalize over it, producing nonsense. It also must
+be done *after* kind-generalization, in order to catch the T2 case, which
+becomes apparent only after generalizing.
 
-How do we deal with all of this? For TyCons, we have checkValidTyConTyVars.
-That function looks to see if any of the tyConTyVars are repeated, but
-it's really a telescope check. It works because all tycons are kind-generalized.
-If there is a bad telescope, the kind-generalization will end up generalizing
-over a variable bound later in the telescope.
+Note [Keeping scoped variables in order: Explicit] discusses how this
+check works for `forall x y z.` written in a type.
 
-For non-tycons, we do scope checking when we bring tyvars into scope,
-in tcImplicitTKBndrs and tcExplicitTKBndrs. Note that we also have to
-sort implicit binders into a well-scoped order whenever we have implicit
-binders to worry about. This is done in quantifyTyVars and in
-tcImplicitTKBndrs.
 -}
 
 -- | Check a list of binders to see if they make a valid telescope.
@@ -1859,29 +2072,21 @@ tcImplicitTKBndrs.
 -- general validity checking, because once we kind-generalise, this sort
 -- of problem is harder to spot (as we'll generalise over the unbound
 -- k in a's type.) See also Note [Bad telescopes].
-checkValidTelescope :: SDoc        -- the original user-written telescope
-                    -> [TyVar]     -- explicit vars (not necessarily zonked)
-                    -> SDoc        -- note to put at bottom of message
+checkValidTelescope :: [TyConBinder]   -- explicit vars (zonked)
+                    -> SDoc            -- original, user-written telescope
+                    -> SDoc            -- extra text to print
                     -> TcM ()
-checkValidTelescope hs_tvs orig_tvs extra
-  = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra
-
--- | Like 'checkZonkValidTelescope', but returns the zonked tyvars
-checkZonkValidTelescope :: SDoc
-                        -> [TyVar]
-                        -> SDoc
-                        -> TcM [TyVar]
-checkZonkValidTelescope hs_tvs orig_tvs extra
-  = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs
-       ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $
-                                      toposortTyVars orig_tvs
-       ; unless (go [] emptyVarSet orig_tvs) $
+checkValidTelescope tvbs user_tyvars extra
+  = do { let tvs      = binderVars tvbs
+
+             (_, sorted_tidied_tvs) = tidyVarBndrs emptyTidyEnv $
+                                      toposortTyVars tvs
+       ; unless (go [] emptyVarSet (binderVars tvbs)) $
          addErr $
-         vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$
+         vcat [ hang (text "These kind and type variables:" <+> user_tyvars $$
                       text "are out of dependency order. Perhaps try this ordering:")
-                   2 (sep (map pprTyVar sorted_tidied_tvs))
-              , extra ]
-       ; return orig_tvs }
+                   2 (pprTyVars sorted_tidied_tvs)
+              , extra ] }
 
   where
     go :: [TyVar]  -- misplaced variables
@@ -1896,37 +2101,6 @@ checkZonkValidTelescope hs_tvs orig_tvs extra
                       tyCoVarsOfTypeList (tyVarKind tv)
         in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
 
--- | After inferring kinds of type variables, check to make sure that the
--- inferred kinds any of the type variables bound in a smaller scope.
--- This is a skolem escape check. See also Note [Bad telescopes].
-checkValidInferredKinds :: [TyVar]     -- ^ vars to check (zonked)
-                        -> TyVarSet    -- ^ vars out of scope
-                        -> SDoc        -- ^ suffix to error message
-                        -> TcM ()
-checkValidInferredKinds orig_kvs out_of_scope extra
-  = do { let bad_pairs = [ (tv, kv)
-                         | kv <- orig_kvs
-                         , Just tv <- map (lookupVarSet out_of_scope)
-                                          (tyCoVarsOfTypeList (tyVarKind kv)) ]
-             report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv)
-               = addErr $
-                 text "The kind of variable" <+>
-                 quotes (ppr kv) <> text ", namely" <+>
-                 quotes (ppr (tyVarKind kv)) <> comma $$
-                 text "depends on variable" <+>
-                 quotes (ppr tv) <+> text "from an inner scope" $$
-                 text "Perhaps bind" <+> quotes (ppr kv) <+>
-                 text "sometime after binding" <+>
-                 quotes (ppr tv) $$
-                 extra
-       ; mapM_ report bad_pairs }
-
-  where
-    (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs
-    (env, _)  = tidyTyCoVarBndrs env1         (nonDetEltsUniqSet out_of_scope)
-      -- It's OK to use nonDetEltsUniqSet here because it's only used for
-      -- generating the error message
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1936,6 +2110,7 @@ checkValidInferredKinds orig_kvs out_of_scope extra
 -}
 
 -- Free variables of a type, retaining repetitions, and expanding synonyms
+-- This ignores coercions, as coercions aren't user-written
 fvType :: Type -> [TyCoVar]
 fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
 fvType (TyVarTy tv)          = [tv]
@@ -1943,64 +2118,39 @@ fvType (TyConApp _ tys)      = fvTypes tys
 fvType (LitTy {})            = []
 fvType (AppTy fun arg)       = fvType fun ++ fvType arg
 fvType (FunTy arg res)       = fvType arg ++ fvType res
-fvType (ForAllTy (TvBndr tv _) ty)
+fvType (ForAllTy (Bndr tv _) ty)
   = fvType (tyVarKind tv) ++
     filter (/= tv) (fvType ty)
-fvType (CastTy ty co)        = fvType ty ++ fvCo co
-fvType (CoercionTy co)       = fvCo co
+fvType (CastTy ty _)         = fvType ty
+fvType (CoercionTy {})       = []
 
 fvTypes :: [Type] -> [TyVar]
 fvTypes tys                = concat (map fvType tys)
 
-fvCo :: Coercion -> [TyCoVar]
-fvCo (Refl _ ty)            = fvType ty
-fvCo (TyConAppCo _ _ args)  = concatMap fvCo args
-fvCo (AppCo co arg)         = fvCo co ++ fvCo arg
-fvCo (ForAllCo tv h co)     = filter (/= tv) (fvCo co) ++ fvCo h
-fvCo (FunCo _ co1 co2)      = fvCo co1 ++ fvCo co2
-fvCo (CoVarCo v)            = [v]
-fvCo (AxiomInstCo _ _ args) = concatMap fvCo args
-fvCo (UnivCo p _ t1 t2)     = fvProv p ++ fvType t1 ++ fvType t2
-fvCo (SymCo co)             = fvCo co
-fvCo (TransCo co1 co2)      = fvCo co1 ++ fvCo co2
-fvCo (NthCo _ co)           = fvCo co
-fvCo (LRCo _ co)            = fvCo co
-fvCo (InstCo co arg)        = fvCo co ++ fvCo arg
-fvCo (CoherenceCo co1 co2)  = fvCo co1 ++ fvCo co2
-fvCo (KindCo co)            = fvCo co
-fvCo (SubCo co)             = fvCo co
-fvCo (AxiomRuleCo _ cs)     = concatMap fvCo cs
-
-fvProv :: UnivCoProvenance -> [TyCoVar]
-fvProv UnsafeCoerceProv    = []
-fvProv (PhantomProv co)    = fvCo co
-fvProv (ProofIrrelProv co) = fvCo co
-fvProv (PluginProv _)      = []
-fvProv (HoleProv h)        = pprPanic "fvProv falls into a hole" (ppr h)
-
 sizeType :: Type -> Int
 -- Size of a type: the number of variables and constructors
 sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
 sizeType (TyVarTy {})      = 1
-sizeType (TyConApp _ tys)  = sizeTypes tys + 1
+sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys
 sizeType (LitTy {})        = 1
 sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
 sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
 sizeType (ForAllTy _ ty)   = sizeType ty
 sizeType (CastTy ty _)     = sizeType ty
-sizeType (CoercionTy _)    = 1
+sizeType (CoercionTy _)    = 0
 
 sizeTypes :: [Type] -> Int
-sizeTypes = sum . map sizeType
+sizeTypes = foldr ((+) . sizeType) 0
+
+sizeTyConAppArgs :: TyCon -> [Type] -> Int
+sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)
+                           -- See Note [Invisible arguments and termination]
 
 -- Size of a predicate
 --
 -- We are considering whether class constraints terminate.
 -- Equality constraints and constraints for the implicit
 -- parameter class always terminate so it is safe to say "size 0".
--- (Implicit parameter constraints always terminate because
--- there are no instances for them---they are only solved by
--- "local instances" in expressions).
 -- See Trac #4200.
 sizePred :: PredType -> Int
 sizePred ty = goClass ty
@@ -2010,14 +2160,19 @@ sizePred ty = goClass ty
     go (ClassPred cls tys')
       | isTerminatingClass cls = 0
       | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')
-    go (EqPred {})        = 0
-    go (IrredPred ty)     = sizeType ty
+                    -- The filtering looks bogus
+                    -- See Note [Invisible arguments and termination]
+    go (EqPred {})           = 0
+    go (IrredPred ty)        = sizeType ty
+    go (ForAllPred _ _ pred) = goClass pred
 
 -- | When this says "True", ignore this class constraint during
 -- a termination check
 isTerminatingClass :: Class -> Bool
 isTerminatingClass cls
-  = isIPClass cls
+  = isIPClass cls    -- Implicit parameter constraints always terminate because
+                     -- there are no instances for them --- they are only solved
+                     -- by "local instances" in expressions
     || cls `hasKey` typeableClassKey
     || cls `hasKey` coercibleTyConKey
     || cls `hasKey` eqTyConKey
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs
index ae1047ebde..a50135bd7b 100644
--- a/compiler/types/Class.hs
+++ b/compiler/types/Class.hs
@@ -17,13 +17,14 @@ module Class (
         mkClass, mkAbstractClass, classTyVars, classArity,
         classKey, className, classATs, classATItems, classTyCon, classMethods,
         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
-        classAllSelIds, classSCSelId, classMinimalDef, classHasFds,
+        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,
         isAbstractClass,
-        naturallyCoherentClass
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} TyCon     ( TyCon )
 import {-# SOURCE #-} TyCoRep   ( Type, PredType, pprType )
 import Var
@@ -32,8 +33,6 @@ import BasicTypes
 import Unique
 import Util
 import SrcLoc
-import PrelNames    ( eqTyConKey, coercibleTyConKey, typeableClassKey,
-                      heqTyConKey )
 import Outputable
 import BooleanFormula (BooleanFormula, mkTrue)
 
@@ -60,6 +59,10 @@ data Class
 
         classTyVars  :: [TyVar],        -- The class kind and type variables;
                                         -- identical to those of the TyCon
+           -- If you want visibility info, look at the classTyCon
+           -- This field is redundant because it's duplicated in the
+           -- classTyCon, but classTyVars is used quite often, so maybe
+           -- it's a bit faster to cache it here
 
         classFunDeps :: [FunDep TyVar],  -- The functional dependencies
 
@@ -104,23 +107,23 @@ data ClassBody
         -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
         -- We need value-level selectors for both the dictionary
         -- superclasses and the equality superclasses
-        classSCThetaStuff :: [PredType],     -- Immediate superclasses,
-        classSCSels  :: [Id],           -- Selector functions to extract the
+        cls_sc_theta :: [PredType],     -- Immediate superclasses,
+        cls_sc_sel_ids :: [Id],          -- Selector functions to extract the
                                         --   superclasses from a
                                         --   dictionary of this class
         -- Associated types
-        classATStuff :: [ClassATItem],  -- Associated type families
+        cls_ats :: [ClassATItem],  -- Associated type families
 
         -- Class operations (methods, not superclasses)
-        classOpStuff :: [ClassOpItem],  -- Ordered by tag
+        cls_ops :: [ClassOpItem],  -- Ordered by tag
 
         -- Minimal complete definition
-        classMinimalDefStuff :: ClassMinimalDef
+        cls_min_def :: ClassMinimalDef
     }
     -- TODO: maybe super classes should be allowed in abstract class definitions
 
 classMinimalDef :: Class -> ClassMinimalDef
-classMinimalDef Class{ classBody = ConcreteClass{ classMinimalDefStuff = d } } = d
+classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d
 classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction
 
 {-
@@ -178,11 +181,11 @@ mkClass cls_name tyvars fds super_classes superdict_sels at_stuff
             classTyVars  = tyvars,
             classFunDeps = fds,
             classBody = ConcreteClass {
-                    classSCThetaStuff = super_classes,
-                    classSCSels  = superdict_sels,
-                    classATStuff = at_stuff,
-                    classOpStuff = op_stuff,
-                    classMinimalDefStuff = mindef
+                    cls_sc_theta = super_classes,
+                    cls_sc_sel_ids = superdict_sels,
+                    cls_ats  = at_stuff,
+                    cls_ops  = op_stuff,
+                    cls_min_def = mindef
                 },
             classTyCon   = tycon }
 
@@ -236,41 +239,47 @@ classArity clas = length (classTyVars clas)
 
 classAllSelIds :: Class -> [Id]
 -- Both superclass-dictionary and method selectors
-classAllSelIds c@(Class { classBody = ConcreteClass { classSCSels = sc_sels }})
+classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
   = sc_sels ++ classMethods c
 classAllSelIds c = ASSERT( null (classMethods c) ) []
 
+classSCSelIds :: Class -> [Id]
+-- Both superclass-dictionary and method selectors
+classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})
+  = sc_sels
+classSCSelIds c = ASSERT( null (classMethods c) ) []
+
 classSCSelId :: Class -> Int -> Id
 -- Get the n'th superclass selector Id
 -- where n is 0-indexed, and counts
 --    *all* superclasses including equalities
-classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n
+classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n
   = ASSERT( n >= 0 && lengthExceeds sc_sels n )
     sc_sels !! n
 classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
 
 classMethods :: Class -> [Id]
-classMethods (Class { classBody = ConcreteClass { classOpStuff = op_stuff } })
+classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })
   = [op_sel | (op_sel, _) <- op_stuff]
 classMethods _ = []
 
 classOpItems :: Class -> [ClassOpItem]
-classOpItems (Class { classBody = ConcreteClass { classOpStuff = op_stuff }})
+classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})
   = op_stuff
 classOpItems _ = []
 
 classATs :: Class -> [TyCon]
-classATs (Class { classBody = ConcreteClass { classATStuff = at_stuff } })
+classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })
   = [tc | ATI tc _ <- at_stuff]
 classATs _ = []
 
 classATItems :: Class -> [ClassATItem]
-classATItems (Class { classBody = ConcreteClass { classATStuff = at_stuff }})
+classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})
   = at_stuff
 classATItems _ = []
 
 classSCTheta :: Class -> [PredType]
-classSCTheta (Class { classBody = ConcreteClass { classSCThetaStuff = theta_stuff }})
+classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})
   = theta_stuff
 classSCTheta _ = []
 
@@ -286,9 +295,9 @@ classBigSig (Class {classTyVars = tyvars,
   = (tyvars, [], [], [])
 classBigSig (Class {classTyVars = tyvars,
                     classBody = ConcreteClass {
-                        classSCThetaStuff = sc_theta,
-                        classSCSels = sc_sels,
-                        classOpStuff = op_stuff
+                        cls_sc_theta = sc_theta,
+                        cls_sc_sel_ids = sc_sels,
+                        cls_ops  = op_stuff
                     }})
   = (tyvars, sc_theta, sc_sels, op_stuff)
 
@@ -298,8 +307,8 @@ classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
   = (tyvars, fundeps, [], [], [], [])
 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
                          classBody = ConcreteClass {
-                             classSCThetaStuff = sc_theta, classSCSels = sc_sels,
-                             classATStuff = ats, classOpStuff = op_stuff
+                             cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,
+                             cls_ats = ats, cls_ops = op_stuff
                          }})
   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 
@@ -307,16 +316,6 @@ isAbstractClass :: Class -> Bool
 isAbstractClass Class{ classBody = AbstractClass } = True
 isAbstractClass _ = False
 
--- | If a class is "naturally coherent", then we needn't worry at all, in any
--- way, about overlapping/incoherent instances. Just solve the thing!
-naturallyCoherentClass :: Class -> Bool
--- See also Note [The equality class story] in TysPrim.
-naturallyCoherentClass cls
-  = cls `hasKey` heqTyConKey ||
-    cls `hasKey` eqTyConKey ||
-    cls `hasKey` coercibleTyConKey ||
-    cls `hasKey` typeableClassKey
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs
index 6d66fb80b1..7f578ec696 100644
--- a/compiler/types/CoAxiom.hs
+++ b/compiler/types/CoAxiom.hs
@@ -7,7 +7,7 @@
 -- and newtypes
 
 module CoAxiom (
-       BranchFlag, Branched, Unbranched, BranchIndex, Branches,
+       BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),
        manyBranches, unbranched,
        fromBranches, numBranches,
        mapAccumBranches,
@@ -29,6 +29,8 @@ module CoAxiom (
        BuiltInSynFamily(..), trivialBuiltInFamily
        ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TyCoRep ( Type, pprType )
 import {-# SOURCE #-} TyCon ( TyCon )
 import Outputable
@@ -220,6 +222,8 @@ data CoAxBranch
                                     -- See Note [CoAxiom locations]
     , cab_tvs      :: [TyVar]       -- Bound type variables; not necessarily fresh
                                     -- See Note [CoAxBranch type variables]
+                                    -- May be eta-reduded; see FamInstEnv
+                                    -- Note [Eta reduction for data families]
     , cab_cvs      :: [CoVar]       -- Bound coercion variables
                                     -- Always empty, for now.
                                     -- See Note [Constraints in patterns]
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index 3f5036c4dd..c766046ea8 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -10,8 +10,9 @@
 --
 module Coercion (
         -- * Main data type
-        Coercion, CoercionN, CoercionR, CoercionP,
-        UnivCoProvenance, CoercionHole, LeftOrRight(..),
+        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
+        UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
+        LeftOrRight(..),
         Var, CoVar, TyCoVar,
         Role(..), ltRole,
 
@@ -22,22 +23,22 @@ module Coercion (
         coercionRole, coercionKindRole,
 
         -- ** Constructing coercions
-        mkReflCo, mkRepReflCo, mkNomReflCo,
+        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,
         mkCoVarCo, mkCoVarCos,
         mkAxInstCo, mkUnbranchedAxInstCo,
         mkAxInstRHS, mkUnbranchedAxInstRHS,
         mkAxInstLHS, mkUnbranchedAxInstLHS,
         mkPiCo, mkPiCos, mkCoCast,
-        mkSymCo, mkTransCo, mkTransAppCo,
-        mkNthCo, mkNthCoRole, mkLRCo,
-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCos,
-        mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl,
-        mkPhantomCo, mkHomoPhantomCo, toPhantomCo,
+        mkSymCo, mkTransCo,
+        mkNthCo, nthCoRole, mkLRCo,
+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,
+        mkForAllCo, mkForAllCos, mkHomoForAllCos,
+        mkPhantomCo,
         mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo,
         mkAxiomInstCo, mkProofIrrelCo,
         downgradeRole, maybeSubCo, mkAxiomRuleCo,
-        mkCoherenceCo, mkCoherenceRightCo, mkCoherenceLeftCo,
-        mkKindCo, castCoercionKind,
+        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,
+        mkKindCo, castCoercionKind, castCoercionKindI,
 
         mkHeteroCoercionType,
 
@@ -48,17 +49,18 @@ module Coercion (
         mapStepResult, unwrapNewTypeStepper,
         topNormaliseNewType_maybe, topNormaliseTypeX,
 
-        decomposeCo, decomposeFunCo, getCoVar_maybe,
+        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,
         splitTyConAppCo_maybe,
         splitAppCo_maybe,
         splitFunCo_maybe,
         splitForAllCo_maybe,
+        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,
 
         nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,
 
         pickLR,
 
-        isReflCo, isReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
+        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
         isReflCoVar_maybe,
 
         -- ** Coercion variables
@@ -79,11 +81,11 @@ module Coercion (
 
         -- ** Lifting
         liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,
-        emptyLiftingContext, extendLiftingContext,
-        liftCoSubstVarBndrCallback, isMappedByLC,
+        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
+        liftCoSubstVarBndrUsing, isMappedByLC,
 
         mkSubstLiftingContext, zapLiftingContext,
-        substForAllCoBndrCallbackLC, lcTCvSubst, lcInScopeSet,
+        substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet,
 
         LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
         substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,
@@ -95,24 +97,27 @@ module Coercion (
         seqCo,
 
         -- * Pretty-printing
-        pprCo, pprParendCo, pprCoBndr,
+        pprCo, pprParendCo,
         pprCoAxiom, pprCoAxBranch, pprCoAxBranchHdr,
 
         -- * Tidying
         tidyCo, tidyCos,
 
         -- * Other
-        promoteCoercion
+        promoteCoercion, buildCoercion
        ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TyCoRep
 import Type
 import TyCon
 import CoAxiom
 import Var
 import VarEnv
+import VarSet
 import Name hiding ( varName )
 import Util
 import BasicTypes
@@ -126,8 +131,7 @@ import ListSetOps
 import Maybes
 import UniqFM
 
-import Control.Monad (foldM)
-import Control.Arrow ( first )
+import Control.Monad (foldM, zipWithM)
 import Data.Function ( on )
 
 {-
@@ -152,117 +156,36 @@ setCoVarUnique = setVarUnique
 setCoVarName :: CoVar -> Name -> CoVar
 setCoVarName   = setVarName
 
-
 {-
 %************************************************************************
 %*                                                                      *
-                   Pretty-printing coercions
+                   Pretty-printing CoAxioms
 %*                                                                      *
 %************************************************************************
 
-@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@
-function is defined to use this.  @pprParendCo@ is the same, except it
-puts parens around the type, except for the atomic cases.
-@pprParendCo@ works just by setting the initial context precedence
-very high.
--}
-
--- Outputable instances are in TyCoRep, to avoid orphans
-
-pprCo, pprParendCo :: Coercion -> SDoc
-pprCo       co = ppr_co TopPrec   co
-pprParendCo co = ppr_co TyConPrec co
-
-ppr_co :: TyPrec -> Coercion -> SDoc
-ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r
-
-ppr_co _ (TyConAppCo r tc cos) = pprTcAppCo TyConPrec ppr_co tc cos <> ppr_role r
-ppr_co p (AppCo co arg)        = maybeParen p TyConPrec $
-                                 pprCo co <+> ppr_co TyConPrec arg
-ppr_co p co@(ForAllCo {})      = ppr_forall_co p co
-ppr_co p co@(FunCo {})         = ppr_fun_co p co
-ppr_co _ (CoVarCo cv)          = parenSymOcc (getOccName cv) (ppr cv)
-ppr_co p (AxiomInstCo con index args)
-  = pprPrefixApp p (ppr (getName con) <> brackets (ppr index))
-                   (map (ppr_co TyConPrec) args)
-
-ppr_co p co@(TransCo {}) = maybeParen p FunPrec $
-                           case trans_co_list co [] of
-                             [] -> panic "ppr_co"
-                             (co:cos) -> sep ( ppr_co FunPrec co
-                                             : [ char ';' <+> ppr_co FunPrec co | co <- cos])
-ppr_co p (InstCo co arg) = maybeParen p TyConPrec $
-                           pprParendCo co <> text "@" <> ppr_co TopPrec arg
-
-ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2)
-  = pprPrefixApp p (text "UnsafeCo" <+> ppr r)
-                   [pprParendType ty1, pprParendType ty2]
-ppr_co _ (UnivCo p r t1 t2)
-  = char 'U'
-    <> parens (ppr_prov <> comma <+> ppr t1 <> comma <+> ppr t2)
-    <> ppr_role r
-  where
-    ppr_prov = case p of
-      HoleProv h          -> text "hole:"   <> ppr h
-      PhantomProv kind_co -> text "phant:"  <> ppr kind_co
-      ProofIrrelProv co   -> text "irrel:"  <> ppr co
-      PluginProv s        -> text "plugin:" <> text s
-      UnsafeCoerceProv    -> text "unsafe"
-
-ppr_co p (SymCo co)          = pprPrefixApp p (text "Sym") [pprParendCo co]
-ppr_co p (NthCo n co)        = pprPrefixApp p (text "Nth:" <> int n) [pprParendCo co]
-ppr_co p (LRCo sel co)       = pprPrefixApp p (ppr sel) [pprParendCo co]
-ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $
-                               (ppr_co FunPrec c1) <+> (text "|>") <+>
-                               (ppr_co FunPrec c2)
-ppr_co p (KindCo co)         = pprPrefixApp p (text "kind") [pprParendCo co]
-ppr_co p (SubCo co)         = pprPrefixApp p (text "Sub") [pprParendCo co]
-ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs
-
-ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc
-ppr_axiom_rule_co co ps = ppr (coaxrName co) <+> parens (interpp'SP ps)
-
-ppr_role :: Role -> SDoc
-ppr_role r = underscore <> pp_role
-  where pp_role = case r of
-                    Nominal          -> char 'N'
-                    Representational -> char 'R'
-                    Phantom          -> char 'P'
-
-trans_co_list :: Coercion -> [Coercion] -> [Coercion]
-trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos)
-trans_co_list co                cos = co : cos
-
-ppr_fun_co :: TyPrec -> Coercion -> SDoc
-ppr_fun_co p co = pprArrowChain p (split co)
-  where
-    split :: Coercion -> [SDoc]
-    split (FunCo _ arg res)
-      = ppr_co FunPrec arg : split res
-    split co = [ppr_co TopPrec co]
-
-ppr_forall_co :: TyPrec -> Coercion -> SDoc
-ppr_forall_co p (ForAllCo tv h co)
-  = maybeParen p FunPrec $
-    sep [pprCoBndr (tyVarName tv) h, ppr_co TopPrec co]
-ppr_forall_co _ _ = panic "ppr_forall_co"
+Defined here to avoid module loops. CoAxiom is loaded very early on.
 
-pprCoBndr :: Name -> Coercion -> SDoc
-pprCoBndr name eta =
-  forAllLit <+> parens (ppr name <+> dcolon <+> ppr eta) <> dot
+-}
 
 pprCoAxiom :: CoAxiom br -> SDoc
 pprCoAxiom ax@(CoAxiom { co_ax_branches = branches })
   = hang (text "axiom" <+> ppr ax <+> dcolon)
-       2 (vcat (map (ppr_co_ax_branch (const ppr) ax) $ fromBranches branches))
+       2 (vcat (map (ppr_co_ax_branch (\_ ty -> equals <+> pprType ty) ax) $
+                    fromBranches branches))
 
 pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
 pprCoAxBranch = ppr_co_ax_branch pprRhs
   where
-    pprRhs fam_tc (TyConApp tycon _)
+    pprRhs fam_tc rhs
       | isDataFamilyTyCon fam_tc
-      = pprDataCons tycon
-    pprRhs _ rhs = ppr rhs
+      = empty -- Don't bother printing anything for the RHS of a data family
+              -- instance...
+
+      | otherwise
+      = equals <+> ppr rhs
+              -- ...but for a type family instance, do print out the RHS, since
+              -- it might be needed to disambiguate between duplicate instances
+              -- (#14179)
 
 pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc
 pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index)
@@ -276,8 +199,8 @@ ppr_co_ax_branch ppr_rhs
                           , cab_rhs = rhs
                           , cab_loc = loc })
   = foldr1 (flip hangNotEmpty 2)
-        [ pprUserForAll (mkTyVarBinders Inferred (tvs ++ cvs))
-        , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs
+        [ pprUserForAll (mkTyCoVarBinders Inferred (ee_tvs ++ cvs))
+        , pprTypeApp fam_tc ee_lhs <+> ppr_rhs fam_tc rhs
         , text "-- Defined" <+> pprLoc loc ]
   where
         pprLoc loc
@@ -288,6 +211,21 @@ ppr_co_ax_branch ppr_rhs
           = text "in" <+>
               quotes (ppr (nameModule name))
 
+        (ee_tvs, ee_lhs)
+          | Just (tycon, tc_args) <- splitTyConApp_maybe rhs
+          , isDataFamilyTyCon fam_tc
+          = -- Eta-expand LHS types, because sometimes data family instances
+            -- are eta-reduced.
+            -- See Note [Eta reduction for data family axioms] in TcInstDecls.
+            let tc_tvs           = tyConTyVars tycon
+                etad_tvs         = dropList tc_args tc_tvs
+                etad_tys         = mkTyVarTys etad_tvs
+                eta_expanded_tvs = tvs `chkAppend` etad_tvs
+                eta_expanded_lhs = lhs `chkAppend` etad_tys
+            in (eta_expanded_tvs, eta_expanded_lhs)
+          | otherwise
+          = (tvs, lhs)
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -311,22 +249,114 @@ where co_rep1, co_rep2 are the coercions on the representations.
 -- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into
 -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:
 --
--- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]
-decomposeCo :: Arity -> Coercion -> [Coercion]
-decomposeCo arity co
-  = [mkNthCo n co | n <- [0..(arity-1)] ]
+-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]
+decomposeCo :: Arity -> Coercion
+            -> [Role]  -- the roles of the output coercions
+                       -- this must have at least as many
+                       -- entries as the Arity provided
+            -> [Coercion]
+decomposeCo arity co rs
+  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]
            -- Remember, Nth is zero-indexed
 
-decomposeFunCo :: Coercion -> (Coercion, Coercion)
+decomposeFunCo :: HasDebugCallStack
+               => Role      -- Role of the input coercion
+               -> Coercion  -- Input coercion
+               -> (Coercion, Coercion)
 -- Expects co :: (s1 -> t1) ~ (s2 -> t2)
 -- Returns (co1 :: s1~s2, co2 :: t1~t2)
 -- See Note [Function coercions] for the "2" and "3"
-decomposeFunCo co = ASSERT2( all_ok, ppr co )
-                    (mkNthCo 2 co, mkNthCo 3 co)
+decomposeFunCo r co = ASSERT2( all_ok, ppr co )
+                      (mkNthCo r 2 co, mkNthCo r 3 co)
   where
     Pair s1t1 s2t2 = coercionKind co
     all_ok = isFunTy s1t1 && isFunTy s2t2
 
+{- Note [Pushing a coercion into a pi-type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this:
+    (f |> co) t1 .. tn
+Then we want to push the coercion into the arguments, so as to make
+progress. For example of why you might want to do so, see Note
+[Respecting definitional equality] in TyCoRep.
+
+This is done by decomposePiCos.  Specifically, if
+    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)
+then
+    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn
+
+Notes:
+
+* k can be smaller than n! That is decomposePiCos can return *fewer*
+  coercions than there are arguments (ie k < n), if the kind provided
+  doesn't have enough binders.
+
+* If there is a type error, we might see
+       (f |> co) t1
+  where co :: (forall a. ty) ~ (ty1 -> ty2)
+  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.
+  So decomposePiCos carefully tests both sides of the coercion to check
+  they are both foralls or both arrows.  Not doing this caused Trac #15343.
+-}
+
+decomposePiCos :: HasDebugCallStack
+               => CoercionN -> Pair Type  -- Coercion and its kind
+               -> [Type]
+               -> ([CoercionN], CoercionN)
+-- See Note [Pushing a coercion into a pi-type]
+decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args
+  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args
+  where
+    orig_subst = mkEmptyTCvSubst $ mkInScopeSet $
+                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co
+
+    go :: [CoercionN]      -- accumulator for argument coercions, reversed
+       -> (TCvSubst,Kind)  -- Lhs kind of coercion
+       -> CoercionN        -- coercion originally applied to the function
+       -> (TCvSubst,Kind)  -- Rhs kind of coercion
+       -> [Type]           -- Arguments to that function
+       -> ([CoercionN], Coercion)
+    -- Invariant:  co :: subst1(k2) ~ subst2(k2)
+
+    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)
+      | Just (a, t1) <- splitForAllTy_maybe k1
+      , Just (b, t2) <- splitForAllTy_maybe k2
+        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)
+        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)
+        --           a :: s1
+        --           b :: s2
+        --          ty :: s2
+        -- need arg_co :: s2 ~ s1
+        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]
+      = let arg_co  = mkNthCo Nominal 0 (mkSymCo co)
+            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)
+            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)
+            subst2' = extendTCvSubst subst2 b ty
+        in
+        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys
+
+      | Just (_s1, t1) <- splitFunTy_maybe k1
+      , Just (_s2, t2) <- splitFunTy_maybe k2
+        -- know     co :: (s1 -> t1) ~ (s2 -> t2)
+        --    function :: s1 -> t1
+        --          ty :: s2
+        -- need arg_co :: s2 ~ s1
+        --      res_co :: t1 ~ t2
+      = let (sym_arg_co, res_co) = decomposeFunCo Nominal co
+            arg_co               = mkSymCo sym_arg_co
+        in
+        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys
+
+      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)
+      = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1)
+                       co
+                       (zapTCvSubst subst2, substTy subst1 k2)
+                       (ty:tys)
+
+      -- tys might not be empty, if the left-hand type of the original coercion
+      -- didn't have enough binders
+    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)
+
 -- | Attempts to obtain the type variable underlying a 'Coercion'
 getCoVar_maybe :: Coercion -> Maybe CoVar
 getCoVar_maybe (CoVarCo cv) = Just cv
@@ -335,7 +365,8 @@ getCoVar_maybe _            = Nothing
 -- | Attempts to tease a coercion apart into a type constructor and the application
 -- of a number of coercion arguments to that constructor
 splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
-splitTyConAppCo_maybe (Refl r ty)
+splitTyConAppCo_maybe co
+  | Just (ty, r) <- isReflCo_maybe co
   = do { (tc, tys) <- splitTyConApp_maybe ty
        ; let args = zipWith mkReflCo (tyConRolesX r tc) tys
        ; return (tc, args) }
@@ -349,16 +380,21 @@ splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
 -- ^ Attempt to take a coercion application apart.
 splitAppCo_maybe (AppCo co arg) = Just (co, arg)
 splitAppCo_maybe (TyConAppCo r tc args)
-  | mightBeUnsaturatedTyCon tc || args `lengthExceeds` tyConArity tc
+  | args `lengthExceeds` tyConArity tc
+  , Just (args', arg') <- snocView args
+  = Just ( mkTyConAppCo r tc args', arg' )
+
+  | mightBeUnsaturatedTyCon tc
     -- Never create unsaturated type family apps!
   , Just (args', arg') <- snocView args
-  , Just arg'' <- setNominalRole_maybe arg'
+  , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'
   = Just ( mkTyConAppCo r tc args', arg'' )
        -- Use mkTyConAppCo to preserve the invariant
        --  that identity coercions are always represented by Refl
 
-splitAppCo_maybe (Refl r ty)
-  | Just (ty1, ty2) <- splitAppTy_maybe ty
+splitAppCo_maybe co
+  | Just (ty, r) <- isReflCo_maybe co
+  , Just (ty1, ty2) <- splitAppTy_maybe ty
   = Just (mkReflCo r ty1, mkNomReflCo ty2)
 splitAppCo_maybe _ = Nothing
 
@@ -366,19 +402,31 @@ splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
 splitFunCo_maybe (FunCo _ arg res) = Just (arg, res)
 splitFunCo_maybe _ = Nothing
 
-splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
+splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)
 splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)
 splitForAllCo_maybe _                     = Nothing
 
+-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder
+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
+splitForAllCo_ty_maybe (ForAllCo tv k_co co)
+  | isTyVar tv = Just (tv, k_co, co)
+splitForAllCo_ty_maybe _ = Nothing
+
+-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder
+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
+splitForAllCo_co_maybe (ForAllCo cv k_co co)
+  | isCoVar cv = Just (cv, k_co, co)
+splitForAllCo_co_maybe _ = Nothing
+
 -------------------------------------------------------
 -- and some coercion kind stuff
 
-coVarTypes :: CoVar -> Pair Type
+coVarTypes :: HasDebugCallStack => CoVar -> Pair Type
 coVarTypes cv
   | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv
   = Pair ty1 ty2
 
-coVarKindsTypesRole :: CoVar -> (Kind,Kind,Type,Type,Role)
+coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)
 coVarKindsTypesRole cv
  | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)
  = let role
@@ -428,33 +476,58 @@ mkHeteroCoercionType Phantom          = panic "mkHeteroCoercionType"
 -- produce a coercion @rep_co :: r1 ~ r2@.
 mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion
 mkRuntimeRepCo co
-  = mkNthCo 0 kind_co
+  = mkNthCo Nominal 0 kind_co
   where
     kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2
                            -- (up to silliness with Constraint)
 
-isReflCoVar_maybe :: CoVar -> Maybe Coercion
+isReflCoVar_maybe :: Var -> Maybe Coercion
 -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)
+-- Works on all kinds of Vars, not just CoVars
 isReflCoVar_maybe cv
-  | Pair ty1 ty2 <- coVarTypes cv
+  | isCoVar cv
+  , Pair ty1 ty2 <- coVarTypes cv
   , ty1 `eqType` ty2
-  = Just (Refl (coVarRole cv) ty1)
+  = Just (mkReflCo (coVarRole cv) ty1)
   | otherwise
   = Nothing
 
+-- | Tests if this coercion is obviously a generalized reflexive coercion.
+-- Guaranteed to work very quickly.
+isGReflCo :: Coercion -> Bool
+isGReflCo (GRefl{}) = True
+isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl
+isGReflCo _         = False
+
+-- | Tests if this MCoercion is obviously generalized reflexive
+-- Guaranteed to work very quickly.
+isGReflMCo :: MCoercion -> Bool
+isGReflMCo MRefl = True
+isGReflMCo (MCo co) | isGReflCo co = True
+isGReflMCo _ = False
+
 -- | Tests if this coercion is obviously reflexive. Guaranteed to work
 -- very quickly. Sometimes a coercion can be reflexive, but not obviously
 -- so. c.f. 'isReflexiveCo'
 isReflCo :: Coercion -> Bool
-isReflCo (Refl {}) = True
-isReflCo _         = False
+isReflCo (Refl{}) = True
+isReflCo (GRefl _ _ mco) | isGReflMCo mco = True
+isReflCo _ = False
+
+-- | Returns the type coerced if this coercion is a generalized reflexive
+-- coercion. Guaranteed to work very quickly.
+isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
+isGReflCo_maybe (GRefl r ty _) = Just (ty, r)
+isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)
+isGReflCo_maybe _ = Nothing
 
 -- | Returns the type coerced if this coercion is reflexive. Guaranteed
 -- to work very quickly. Sometimes a coercion can be reflexive, but not
 -- obviously so. c.f. 'isReflexiveCo_maybe'
 isReflCo_maybe :: Coercion -> Maybe (Type, Role)
-isReflCo_maybe (Refl r ty) = Just (ty, r)
-isReflCo_maybe _           = Nothing
+isReflCo_maybe (Refl ty) = Just (ty, Nominal)
+isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
+isReflCo_maybe _ = Nothing
 
 -- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
 -- as it walks over the entire coercion.
@@ -464,7 +537,8 @@ isReflexiveCo = isJust . isReflexiveCo_maybe
 -- | Extracts the coerced type from a reflexive coercion. This potentially
 -- walks over the entire coercion, so avoid doing this in a loop.
 isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)
-isReflexiveCo_maybe (Refl r ty) = Just (ty, r)
+isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)
+isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
 isReflexiveCo_maybe co
   | ty1 `eqType` ty2
   = Just (ty1, r)
@@ -532,54 +606,27 @@ One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as
 appropriate? I (Richard E.) have decided not to do this, because upgrading a
 role is bizarre and a caller should have to ask for this behavior explicitly.
 
-Note [mkTransAppCo]
-~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-  co1 :: a ~R Maybe
-  co2 :: b ~R Int
-
-and we want
-
-  co3 :: a b ~R Maybe Int
-
-This seems sensible enough. But, we can't let (co3 = co1 co2), because
-that's ill-roled! Note that mkAppCo requires a *nominal* second coercion.
-
-The way around this is to use transitivity:
-
-  co3 = (co1 <b>_N) ; (Maybe co2) :: a b ~R Maybe Int
-
-Or, it's possible everything is the other way around:
-
-  co1' :: Maybe ~R a
-  co2' :: Int   ~R b
-
-and we want
-
-  co3' :: Maybe Int ~R a b
-
-then
-
-  co3' = (Maybe co2') ; (co1' <b>_N)
-
-This is exactly what `mkTransAppCo` builds for us. Information for all
-the arguments tends to be to hand at call sites, so it's quicker than
-using, say, coercionKind.
-
 -}
 
+-- | Make a generalized reflexive coercion
+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
+mkGReflCo r ty mco
+  | isGReflMCo mco = if r == Nominal then Refl ty
+                     else GRefl r ty MRefl
+  | otherwise    = GRefl r ty mco
+
+-- | Make a reflexive coercion
 mkReflCo :: Role -> Type -> Coercion
-mkReflCo r ty
-  = Refl r ty
+mkReflCo Nominal ty = Refl ty
+mkReflCo r       ty = GRefl r ty MRefl
 
 -- | Make a representational reflexive coercion
 mkRepReflCo :: Type -> Coercion
-mkRepReflCo = mkReflCo Representational
+mkRepReflCo ty = GRefl Representational ty MRefl
 
 -- | Make a nominal reflexive coercion
 mkNomReflCo :: Type -> Coercion
-mkNomReflCo = mkReflCo Nominal
+mkNomReflCo = Refl
 
 -- | Apply a type constructor to a list of coercions. It is the
 -- caller's responsibility to get the roles correct on argument coercions.
@@ -597,7 +644,8 @@ mkTyConAppCo r tc cos
   = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos
 
   | Just tys_roles <- traverse isReflCo_maybe cos
-  = Refl r (mkTyConApp tc (map fst tys_roles))    -- See Note [Refl invariant]
+  = mkReflCo r (mkTyConApp tc (map fst tys_roles))
+  -- See Note [Refl invariant]
 
   | otherwise = TyConAppCo r tc cos
 
@@ -608,24 +656,22 @@ mkFunCo r co1 co2
     -- See Note [Refl invariant]
   | Just (ty1, _) <- isReflCo_maybe co1
   , Just (ty2, _) <- isReflCo_maybe co2
-  = Refl r (mkFunTy ty1 ty2)
+  = mkReflCo r (mkFunTy ty1 ty2)
   | otherwise = FunCo r co1 co2
 
--- | Make nested function 'Coercion's
-mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion
-mkFunCos r cos res_co = foldr (mkFunCo r) res_co cos
-
 -- | Apply a 'Coercion' to another 'Coercion'.
 -- The second coercion must be Nominal, unless the first is Phantom.
 -- If the first is Phantom, then the second can be either Phantom or Nominal.
 mkAppCo :: Coercion     -- ^ :: t1 ~r t2
         -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2
         -> Coercion     -- ^ :: t1 s1 ~r t2 s2
-mkAppCo (Refl r ty1) arg
-  | Just (ty2, _) <- isReflCo_maybe arg
-  = Refl r (mkAppTy ty1 ty2)
+mkAppCo co arg
+  | Just (ty1, r) <- isReflCo_maybe co
+  , Just (ty2, _) <- isReflCo_maybe arg
+  = mkReflCo r (mkAppTy ty1 ty2)
 
-  | Just (tc, tys) <- splitTyConApp_maybe ty1
+  | Just (ty1, r) <- isReflCo_maybe co
+  , Just (tc, tys) <- splitTyConApp_maybe ty1
     -- Expand type synonyms; a TyConAppCo can't have a type synonym (Trac #9102)
   = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)
   where
@@ -650,102 +696,83 @@ mkAppCo co arg = AppCo co  arg
 mkAppCos :: Coercion
          -> [Coercion]
          -> Coercion
-mkAppCos co1 cos = foldl mkAppCo co1 cos
-
--- | Like `mkAppCo`, but allows the second coercion to be other than
--- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent
--- than either r1 or r2.
-mkTransAppCo :: Role         -- ^ r1
-             -> Coercion     -- ^ co1 :: ty1a ~r1 ty1b
-             -> Type         -- ^ ty1a
-             -> Type         -- ^ ty1b
-             -> Role         -- ^ r2
-             -> Coercion     -- ^ co2 :: ty2a ~r2 ty2b
-             -> Type         -- ^ ty2a
-             -> Type         -- ^ ty2b
-             -> Role         -- ^ r3
-             -> Coercion     -- ^ :: ty1a ty2a ~r3 ty1b ty2b
-mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3
--- How incredibly fiddly! Is there a better way??
-  = case (r1, r2, r3) of
-      (_,                _,                Phantom)
-        -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b)
-        where -- ty1a :: k1a -> k2a
-              -- ty1b :: k1b -> k2b
-              -- ty2a :: k1a
-              -- ty2b :: k1b
-              -- ty1a ty2a :: k2a
-              -- ty1b ty2b :: k2b
-              kind_co1 = mkKindCo co1        -- :: k1a -> k2a ~N k1b -> k2b
-              kind_co  = mkNthCo 1 kind_co1  -- :: k2a ~N k2b
-
-      (_,                _,                Nominal)
-        -> ASSERT( r1 == Nominal && r2 == Nominal )
-           mkAppCo co1 co2
-      (Nominal,          Nominal,          Representational)
-        -> mkSubCo (mkAppCo co1 co2)
-      (_,                Nominal,          Representational)
-        -> ASSERT( r1 == Representational )
-           mkAppCo co1 co2
-      (Nominal,          Representational, Representational)
-        -> go (mkSubCo co1)
-      (_               , _,                Representational)
-        -> ASSERT( r1 == Representational && r2 == Representational )
-           go co1
-  where
-    go co1_repr
-      | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b
-      , nextRole ty1b == r2
-      = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo`
-        (mkTyConAppCo Representational tc1b
-           (zipWith mkReflCo (tyConRolesRepresentational tc1b) tys1b
-            ++ [co2]))
-
-      | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a
-      , nextRole ty1a == r2
-      = (mkTyConAppCo Representational tc1a
-           (zipWith mkReflCo (tyConRolesRepresentational tc1a) tys1a
-            ++ [co2]))
-        `mkTransCo`
-        (mkAppCo co1_repr (mkNomReflCo ty2b))
+mkAppCos co1 cos = foldl' mkAppCo co1 cos
 
-      | otherwise
-      = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b
-                                      , ppr r2, ppr co2, ppr ty2a, ppr ty2b
-                                      , ppr r3 ])
+{- Note [Unused coercion variable in ForAllCo]
+
+See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for
+checking coercion variable in types.
+To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:
+
+(1) In mkForAllCo, we check whether cv is a coercion variable
+    and whether it is not used in body_co. If so we construct a FunCo.
+(2) We don't do this check in mkForAllCo.
+    In coercionKind, we use mkTyCoForAllTy to perform the check and construct
+    a FunTy when necessary.
+
+We chose (2) for two reasons:
 
--- | Make a Coercion from a tyvar, a kind coercion, and a body coercion.
--- The kind of the tyvar should be the left-hand kind of the kind coercion.
-mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion
+* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not
+  make a difference.
+* even if cv occurs in body_co, it is possible that cv does not occur in the kind
+  of body_co. Therefore the check in coercionKind is inevitable.
+
+-}
+
+
+-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.
+-- The kind of the tycovar should be the left-hand kind of the kind coercion.
+-- See Note [Unused coercion variable in ForAllCo]
+mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion
 mkForAllCo tv kind_co co
-  | Refl r ty <- co
-  , Refl {} <- kind_co
-  = Refl r (mkInvForAllTy tv ty)
+  | ASSERT( varType tv `eqType` (pFst $ coercionKind kind_co)) True
+  , Just (ty, r) <- isReflCo_maybe co
+  , isGReflCo kind_co
+  = mkReflCo r (mkTyCoInvForAllTy tv ty)
+  | otherwise
+  = ForAllCo tv kind_co co
+
+-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious
+-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.
+-- The kind of the tycovar should be the left-hand kind of the kind coercion.
+mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion
+mkForAllCo_NoRefl tv kind_co co
+  | ASSERT( varType tv `eqType` (pFst $ coercionKind kind_co)) True
+  , ASSERT( not (isReflCo co)) True
+  , isCoVar tv
+  , not (tv `elemVarSet` tyCoVarsOfCo co)
+  = FunCo (coercionRole co) kind_co co
   | otherwise
   = ForAllCo tv kind_co co
 
 -- | Make nested ForAllCos
-mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion
-mkForAllCos bndrs (Refl r ty)
+mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion
+mkForAllCos bndrs co
+  | Just (ty, r ) <- isReflCo_maybe co
   = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in
-    foldl (flip $ uncurry ForAllCo)
-          (Refl r $ mkInvForAllTys (reverse (map fst refls_rev'd)) ty)
-          non_refls_rev'd
-mkForAllCos bndrs co = foldr (uncurry ForAllCo) co bndrs
+    foldl' (flip $ uncurry mkForAllCo_NoRefl)
+           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))
+           non_refls_rev'd
+  | otherwise
+  = foldr (uncurry mkForAllCo_NoRefl) co bndrs
 
--- | Make a Coercion quantified over a type variable;
+-- | Make a Coercion quantified over a type/coercion variable;
 -- the variable has the same type in both sides of the coercion
-mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion
-mkHomoForAllCos tvs (Refl r ty)
-  = Refl r (mkInvForAllTys tvs ty)
-mkHomoForAllCos tvs ty = mkHomoForAllCos_NoRefl tvs ty
-
--- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion
--- is reflexive.
-mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion
-mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs
+mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion
+mkHomoForAllCos tvs co
+  | Just (ty, r) <- isReflCo_maybe co
+  = mkReflCo r (mkTyCoInvForAllTys tvs ty)
+  | otherwise
+  = mkHomoForAllCos_NoRefl tvs co
+
+-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious
+-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.
+mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion
+mkHomoForAllCos_NoRefl tvs orig_co
+  = ASSERT( not (isReflCo orig_co))
+    foldr go orig_co tvs
   where
-    go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co
+    go tv co = mkForAllCo_NoRefl tv (mkNomReflCo (varType tv)) co
 
 mkCoVarCo :: CoVar -> Coercion
 -- cv :: s ~# t
@@ -794,7 +821,7 @@ mkAxInstCo role ax index tys cos
                   = splitAt arity rtys
     ax_role       = coAxiomRole ax
 
--- worker function; just checks to see if it should produce Refl
+-- worker function
 mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
 mkAxiomInstCo ax index args
   = ASSERT( args `lengthIs` coAxiomArity ax index )
@@ -855,9 +882,8 @@ mkUnsafeCo role ty1 ty2
   = mkUnivCo UnsafeCoerceProv role ty1 ty2
 
 -- | Make a coercion from a coercion hole
-mkHoleCo :: CoercionHole -> Role
-         -> Type -> Type -> Coercion
-mkHoleCo h r t1 t2 = mkUnivCo (HoleProv h) r t1 t2
+mkHoleCo :: CoercionHole -> Coercion
+mkHoleCo h = HoleCo h
 
 -- | Make a universal coercion between two arbitrary types.
 mkUnivCo :: UnivCoProvenance
@@ -866,7 +892,7 @@ mkUnivCo :: UnivCoProvenance
          -> Type       -- ^ t2 :: k2
          -> Coercion   -- ^ :: t1 ~r t2
 mkUnivCo prov role ty1 ty2
-  | ty1 `eqType` ty2 = Refl role ty1
+  | ty1 `eqType` ty2 = mkReflCo role ty1
   | otherwise        = UnivCo prov role ty1 ty2
 
 -- | Create a symmetric version of the given 'Coercion' that asserts
@@ -876,7 +902,7 @@ mkSymCo :: Coercion -> Coercion
 
 -- Do a few simple optimizations, but don't bother pushing occurrences
 -- of symmetry to the leaves; the optimizer will take care of that.
-mkSymCo co@(Refl {})              = co
+mkSymCo co | isReflCo co          = co
 mkSymCo    (SymCo co)             = co
 mkSymCo    (SubCo (SymCo co))     = SubCo co
 mkSymCo co                        = SymCo co
@@ -884,101 +910,193 @@ mkSymCo co                        = SymCo co
 -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
 --   (co1 ; co2)
 mkTransCo :: Coercion -> Coercion -> Coercion
-mkTransCo co1 (Refl {}) = co1
-mkTransCo (Refl {}) co2 = co2
-mkTransCo co1 co2       = TransCo co1 co2
-
--- the Role is the desired one. It is the caller's responsibility to make
--- sure this request is reasonable
-mkNthCoRole :: Role -> Int -> Coercion -> Coercion
-mkNthCoRole role n co
-  = downgradeRole role nth_role $ nth_co
+mkTransCo co1 co2 | isReflCo co1 = co2
+                  | isReflCo co2 = co1
+mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))
+  = GRefl r t1 (MCo $ mkTransCo co1 co2)
+mkTransCo co1 co2                 = TransCo co1 co2
+
+mkNthCo :: HasDebugCallStack
+        => Role  -- the role of the coercion you're creating
+        -> Int
+        -> Coercion
+        -> Coercion
+mkNthCo r n co
+  = ASSERT2( good_call, bad_call_msg )
+    go r n co
   where
-    nth_co = mkNthCo n co
-    nth_role = coercionRole nth_co
-
-mkNthCo :: Int -> Coercion -> Coercion
-mkNthCo 0 (Refl _ ty)
-  | Just (tv, _) <- splitForAllTy_maybe ty
-  = Refl Nominal (tyVarKind tv)
-mkNthCo n (Refl r ty)
-  = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )
-    mkReflCo r' (tyConAppArgN n ty)
-  where tc = tyConAppTyCon ty
-        r' = nthRole r tc n
-
-        ok_tc_app :: Type -> Int -> Bool
-        ok_tc_app ty n
-          | Just (_, tys) <- splitTyConApp_maybe ty
-          = tys `lengthExceeds` n
-          | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall
-          = n == 0
-          | otherwise
-          = False
-
-mkNthCo 0 (ForAllCo _ kind_co _) = kind_co
-  -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
-  -- then (nth 0 co :: k1 ~ k2)
-
-mkNthCo n co@(FunCo _ arg res)
-  -- See Note [Function coercions]
-  -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)
-  --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)
-  -- Then we want to behave as if co was
-  --    TyConAppCo argk_co resk_co arg_co res_co
-  -- where
-  --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)
-  --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)
-  --                             i.e. mkRuntimeRepCo
-  = case n of
-      0 -> mkRuntimeRepCo arg
-      1 -> mkRuntimeRepCo res
-      2 -> arg
-      3 -> res
-      _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)
-
-mkNthCo n (TyConAppCo _ _ arg_cos) = arg_cos `getNth` n
-
-mkNthCo n co = NthCo n co
+    Pair ty1 ty2 = coercionKind co
+
+    go r 0 co
+      | Just (ty, _) <- isReflCo_maybe co
+      , Just (tv, _) <- splitForAllTy_maybe ty
+      = -- works for both tyvar and covar
+        ASSERT( r == Nominal )
+        mkNomReflCo (varType tv)
+
+    go r n co
+      | Just (ty, r0) <- isReflCo_maybe co
+      , let tc = tyConAppTyCon ty
+      = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )
+        ASSERT( nthRole r0 tc n == r )
+        mkReflCo r (tyConAppArgN n ty)
+      where ok_tc_app :: Type -> Int -> Bool
+            ok_tc_app ty n
+              | Just (_, tys) <- splitTyConApp_maybe ty
+              = tys `lengthExceeds` n
+              | isForAllTy ty  -- nth:0 pulls out a kind coercion from a hetero forall
+              = n == 0
+              | otherwise
+              = False
+
+    go r 0 (ForAllCo _ kind_co _)
+      = ASSERT( r == Nominal )
+        kind_co
+      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)
+      -- then (nth 0 co :: k1 ~N k2)
+      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
+      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))
+
+    go r n co@(FunCo r0 arg res)
+      -- See Note [Function coercions]
+      -- If FunCo _ arg_co res_co ::   (s1:TYPE sk1 -> s2:TYPE sk2)
+      --                             ~ (t1:TYPE tk1 -> t2:TYPE tk2)
+      -- Then we want to behave as if co was
+      --    TyConAppCo argk_co resk_co arg_co res_co
+      -- where
+      --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)
+      --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)
+      --                             i.e. mkRuntimeRepCo
+      = case n of
+          0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg
+          1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res
+          2 -> ASSERT( r == r0 )      arg
+          3 -> ASSERT( r == r0 )      res
+          _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)
+
+    go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n
+                                                    , (vcat [ ppr tc
+                                                            , ppr arg_cos
+                                                            , ppr r0
+                                                            , ppr n
+                                                            , ppr r ]) )
+                                             arg_cos `getNth` n
+
+    go r n co =
+      NthCo r n co
+
+    -- Assertion checking
+    bad_call_msg = vcat [ text "Coercion =" <+> ppr co
+                        , text "LHS ty =" <+> ppr ty1
+                        , text "RHS ty =" <+> ppr ty2
+                        , text "n =" <+> ppr n, text "r =" <+> ppr r
+                        , text "coercion role =" <+> ppr (coercionRole co) ]
+    good_call
+      -- If the Coercion passed in is between forall-types, then the Int must
+      -- be 0 and the role must be Nominal.
+      | Just (_tv1, _) <- splitForAllTy_maybe ty1
+      , Just (_tv2, _) <- splitForAllTy_maybe ty2
+      = n == 0 && r == Nominal
+
+      -- If the Coercion passed in is between T tys and T tys', then the Int
+      -- must be less than the length of tys/tys' (which must be the same
+      -- lengths).
+      --
+      -- If the role of the Coercion is nominal, then the role passed in must
+      -- be nominal. If the role of the Coercion is representational, then the
+      -- role passed in must be tyConRolesRepresentational T !! n. If the role
+      -- of the Coercion is Phantom, then the role passed in must be Phantom.
+      --
+      -- See also Note [NthCo Cached Roles] if you're wondering why it's
+      -- blaringly obvious that we should be *computing* this role instead of
+      -- passing it in.
+      | Just (tc1, tys1) <- splitTyConApp_maybe ty1
+      , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+      , tc1 == tc2
+      = let len1 = length tys1
+            len2 = length tys2
+            good_role = case coercionRole co of
+                          Nominal -> r == Nominal
+                          Representational -> r == (tyConRolesRepresentational tc1 !! n)
+                          Phantom -> r == Phantom
+        in len1 == len2 && n < len1 && good_role
+
+      | otherwise
+      = True
+
+
+
+-- | If you're about to call @mkNthCo r n co@, then @r@ should be
+-- whatever @nthCoRole n co@ returns.
+nthCoRole :: Int -> Coercion -> Role
+nthCoRole n co
+  | Just (tc, _) <- splitTyConApp_maybe lty
+  = nthRole r tc n
+
+  | Just _ <- splitForAllTy_maybe lty
+  = Nominal
+
+  | otherwise
+  = pprPanic "nthCoRole" (ppr co)
+
+  where
+    (Pair lty _, r) = coercionKindRole co
 
 mkLRCo :: LeftOrRight -> Coercion -> Coercion
-mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty))
-mkLRCo lr co           = LRCo lr co
+mkLRCo lr co
+  | Just (ty, eq) <- isReflCo_maybe co
+  = mkReflCo eq (pickLR lr (splitAppTy ty))
+  | otherwise
+  = LRCo lr co
 
 -- | Instantiates a 'Coercion'.
 mkInstCo :: Coercion -> Coercion -> Coercion
-mkInstCo (ForAllCo tv _kind_co body_co) (Refl _ arg)
-  = substCoWithUnchecked [tv] [arg] body_co
+mkInstCo (ForAllCo tcv _kind_co body_co) co
+  | Just (arg, _) <- isReflCo_maybe co
+      -- works for both tyvar and covar
+  = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co
 mkInstCo co arg = InstCo co arg
 
--- This could work harder to produce Refl coercions, but that would be
--- quite inefficient. Seems better not to try.
-mkCoherenceCo :: Coercion -> Coercion -> Coercion
-mkCoherenceCo co1 (Refl {}) = co1
-mkCoherenceCo (CoherenceCo co1 co2) co3
-  = CoherenceCo co1 (co2 `mkTransCo` co3)
-mkCoherenceCo co1 co2     = CoherenceCo co1 co2
-
--- | A CoherenceCo c1 c2 applies the coercion c2 to the left-hand type
--- in the kind of c1. This function uses sym to get the coercion on the
--- right-hand type of c1. Thus, if c1 :: s ~ t, then mkCoherenceRightCo c1 c2
--- has the kind (s ~ (t |> c2)) down through type constructors.
--- The second coercion must be representational.
-mkCoherenceRightCo :: Coercion -> Coercion -> Coercion
-mkCoherenceRightCo c1 c2 = mkSymCo (mkCoherenceCo (mkSymCo c1) c2)
-
--- | An explicitly directed synonym of mkCoherenceCo. The second
--- coercion must be representational.
-mkCoherenceLeftCo :: Coercion -> Coercion -> Coercion
-mkCoherenceLeftCo = mkCoherenceCo
-
-infixl 5 `mkCoherenceCo`
-infixl 5 `mkCoherenceRightCo`
-infixl 5 `mkCoherenceLeftCo`
+-- | Given @ty :: k1@, @co :: k1 ~ k2@,
+-- produces @co' :: ty ~r (ty |> co)@
+mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion
+mkGReflRightCo r ty co
+  | isGReflCo co = mkReflCo r ty
+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
+    -- instead of @isReflCo@
+  | otherwise = GRefl r ty (MCo co)
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@,
+-- produces @co' :: (ty |> co) ~r ty@
+mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion
+mkGReflLeftCo r ty co
+  | isGReflCo co = mkReflCo r ty
+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
+    -- instead of @isReflCo@
+  | otherwise    = mkSymCo $ GRefl r ty (MCo co)
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~ ty'@,
+-- produces @co' :: (ty |> co) ~r ty'
+-- It is not only a utility function, but it saves allocation when co
+-- is a GRefl coercion.
+mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
+mkCoherenceLeftCo r ty co co2
+  | isGReflCo co = co2
+  | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~ ty@,
+-- produces @co' :: ty' ~r (ty |> co)
+-- It is not only a utility function, but it saves allocation when co
+-- is a GRefl coercion.
+mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
+mkCoherenceRightCo r ty co co2
+  | isGReflCo co = co2
+  | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)
 
 -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
 mkKindCo :: Coercion -> Coercion
-mkKindCo (Refl _ ty) = Refl Nominal (typeKind ty)
+mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)
+mkKindCo (GRefl _ _ (MCo co)) = co
 mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h
 mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h
 mkKindCo co
@@ -989,13 +1107,15 @@ mkKindCo co
   , let tk1 = typeKind ty1
         tk2 = typeKind ty2
   , tk1 `eqType` tk2
-  = Refl Nominal tk1
+  = Refl tk1
   | otherwise
   = KindCo co
 
--- input coercion is Nominal; see also Note [Role twiddling functions]
 mkSubCo :: Coercion -> Coercion
-mkSubCo (Refl Nominal ty) = Refl Representational ty
+-- Input coercion is Nominal, result is Representational
+-- see also Note [Role twiddling functions]
+mkSubCo (Refl ty) = GRefl Representational ty MRefl
+mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co
 mkSubCo (TyConAppCo Nominal tc cos)
   = TyConAppCo Representational tc (applyRoles tc cos)
 mkSubCo (FunCo Nominal arg res)
@@ -1011,12 +1131,16 @@ downgradeRole_maybe :: Role   -- ^ desired role
                     -> Coercion -> Maybe Coercion
 -- In (downgradeRole_maybe dr cr co) it's a precondition that
 --                                   cr = coercionRole co
-downgradeRole_maybe Representational Nominal co = Just (mkSubCo co)
-downgradeRole_maybe Nominal Representational _  = Nothing
-downgradeRole_maybe Phantom Phantom          co = Just co
-downgradeRole_maybe Phantom _                co = Just (toPhantomCo co)
-downgradeRole_maybe _ Phantom                _  = Nothing
-downgradeRole_maybe _ _                      co = Just co
+
+downgradeRole_maybe Nominal          Nominal          co = Just co
+downgradeRole_maybe Nominal          _                _  = Nothing
+
+downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)
+downgradeRole_maybe Representational Representational co = Just co
+downgradeRole_maybe Representational Phantom          _  = Nothing
+
+downgradeRole_maybe Phantom          Phantom          co = Just co
+downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)
 
 -- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.
 -- See Note [Role twiddling functions]
@@ -1047,9 +1171,10 @@ mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"
 
 -- if the two coercion prove the same fact, I just don't care what
 -- the individual coercions are.
-mkProofIrrelCo r (Refl {}) g  _  = Refl r (CoercionTy g)
-mkProofIrrelCo r kco       g1 g2 = mkUnivCo (ProofIrrelProv kco) r
-                                     (mkCoercionTy g1) (mkCoercionTy g2)
+mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)
+  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@
+mkProofIrrelCo r kco        g1 g2 = mkUnivCo (ProofIrrelProv kco) r
+                                             (mkCoercionTy g1) (mkCoercionTy g2)
 
 {-
 %************************************************************************
@@ -1061,41 +1186,44 @@ mkProofIrrelCo r kco       g1 g2 = mkUnivCo (ProofIrrelProv kco) r
 
 -- | Converts a coercion to be nominal, if possible.
 -- See Note [Role twiddling functions]
-setNominalRole_maybe :: Coercion -> Maybe Coercion
-setNominalRole_maybe co
-  | Nominal <- coercionRole co = Just co
-setNominalRole_maybe (SubCo co)  = Just co
-setNominalRole_maybe (Refl _ ty) = Just $ Refl Nominal ty
-setNominalRole_maybe (TyConAppCo Representational tc cos)
-  = do { cos' <- mapM setNominalRole_maybe cos
-       ; return $ TyConAppCo Nominal tc cos' }
-setNominalRole_maybe (FunCo Representational co1 co2)
-  = do { co1' <- setNominalRole_maybe co1
-       ; co2' <- setNominalRole_maybe co2
-       ; return $ FunCo Nominal co1' co2'
-       }
-setNominalRole_maybe (SymCo co)
-  = SymCo <$> setNominalRole_maybe co
-setNominalRole_maybe (TransCo co1 co2)
-  = TransCo <$> setNominalRole_maybe co1 <*> setNominalRole_maybe co2
-setNominalRole_maybe (AppCo co1 co2)
-  = AppCo <$> setNominalRole_maybe co1 <*> pure co2
-setNominalRole_maybe (ForAllCo tv kind_co co)
-  = ForAllCo tv kind_co <$> setNominalRole_maybe co
-setNominalRole_maybe (NthCo n co)
-  = NthCo n <$> setNominalRole_maybe co
-setNominalRole_maybe (InstCo co arg)
-  = InstCo <$> setNominalRole_maybe co <*> pure arg
-setNominalRole_maybe (CoherenceCo co1 co2)
-  = CoherenceCo <$> setNominalRole_maybe co1 <*> pure co2
-setNominalRole_maybe (UnivCo prov _ co1 co2)
-  | case prov of UnsafeCoerceProv -> True   -- it's always unsafe
-                 PhantomProv _    -> False  -- should always be phantom
-                 ProofIrrelProv _ -> True   -- it's always safe
-                 PluginProv _     -> False  -- who knows? This choice is conservative.
-                 HoleProv _       -> False  -- no no no.
-  = Just $ UnivCo prov Nominal co1 co2
-setNominalRole_maybe _ = Nothing
+setNominalRole_maybe :: Role -- of input coercion
+                     -> Coercion -> Maybe Coercion
+setNominalRole_maybe r co
+  | r == Nominal = Just co
+  | otherwise = setNominalRole_maybe_helper co
+  where
+    setNominalRole_maybe_helper (SubCo co)  = Just co
+    setNominalRole_maybe_helper co@(Refl _) = Just co
+    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co
+    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)
+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos
+           ; return $ TyConAppCo Nominal tc cos' }
+    setNominalRole_maybe_helper (FunCo Representational co1 co2)
+      = do { co1' <- setNominalRole_maybe Representational co1
+           ; co2' <- setNominalRole_maybe Representational co2
+           ; return $ FunCo Nominal co1' co2'
+           }
+    setNominalRole_maybe_helper (SymCo co)
+      = SymCo <$> setNominalRole_maybe_helper co
+    setNominalRole_maybe_helper (TransCo co1 co2)
+      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2
+    setNominalRole_maybe_helper (AppCo co1 co2)
+      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2
+    setNominalRole_maybe_helper (ForAllCo tv kind_co co)
+      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co
+    setNominalRole_maybe_helper (NthCo _r n co)
+      -- NB, this case recurses via setNominalRole_maybe, not
+      -- setNominalRole_maybe_helper!
+      = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co
+    setNominalRole_maybe_helper (InstCo co arg)
+      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg
+    setNominalRole_maybe_helper (UnivCo prov _ co1 co2)
+      | case prov of UnsafeCoerceProv -> True   -- it's always unsafe
+                     PhantomProv _    -> False  -- should always be phantom
+                     ProofIrrelProv _ -> True   -- it's always safe
+                     PluginProv _     -> False  -- who knows? This choice is conservative.
+      = Just $ UnivCo prov Nominal co1 co2
+    setNominalRole_maybe_helper _ = Nothing
 
 -- | Make a phantom coercion between two types. The coercion passed
 -- in must be a nominal coercion between the kinds of the
@@ -1104,14 +1232,6 @@ mkPhantomCo :: Coercion -> Type -> Type -> Coercion
 mkPhantomCo h t1 t2
   = mkUnivCo (PhantomProv h) Phantom t1 t2
 
--- | Make a phantom coercion between two types of the same kind.
-mkHomoPhantomCo :: Type -> Type -> Coercion
-mkHomoPhantomCo t1 t2
-  = ASSERT( k1 `eqType` typeKind t2 )
-    mkPhantomCo (mkNomReflCo k1) t1 t2
-  where
-    k1 = typeKind t1
-
 -- takes any coercion and turns it into a Phantom coercion
 toPhantomCo :: Coercion -> Coercion
 toPhantomCo co
@@ -1124,7 +1244,7 @@ applyRoles tc cos
   = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos
 
 -- the Role parameter is the Role of the TyConAppCo
--- defined here because this is intimiately concerned with the implementation
+-- defined here because this is intimately concerned with the implementation
 -- of TyConAppCo
 tyConRolesX :: Role -> TyCon -> [Role]
 tyConRolesX Representational tc = tyConRolesRepresentational tc
@@ -1152,7 +1272,7 @@ ltRole Nominal          _       = True
 
 -- | like mkKindCo, but aggressively & recursively optimizes to avoid using
 -- a KindCo constructor. The output role is nominal.
-promoteCoercion :: Coercion -> Coercion
+promoteCoercion :: Coercion -> CoercionN
 
 -- First cases handles anything that should yield refl.
 promoteCoercion co = case co of
@@ -1163,8 +1283,13 @@ promoteCoercion co = case co of
      --    The ASSERT( False )s throughout
      -- are these cases explicitly, but they should never fire.
 
-    Refl _ ty -> ASSERT( False )
-                 mkNomReflCo (typeKind ty)
+    Refl _ -> ASSERT( False )
+              mkNomReflCo ki1
+
+    GRefl _ _ MRefl -> ASSERT( False )
+                       mkNomReflCo ki1
+
+    GRefl _ _ (MCo co) -> co
 
     TyConAppCo _ tc args
       | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args
@@ -1179,28 +1304,28 @@ promoteCoercion co = case co of
       | otherwise
       -> mkKindCo co
 
-    ForAllCo _ _ g
+    ForAllCo tv _ g
+      | isTyVar tv
       -> promoteCoercion g
 
-    FunCo _ _ _
-      -> mkNomReflCo liftedTypeKind
+    ForAllCo _ _ _
+      -> ASSERT( False )
+         mkNomReflCo liftedTypeKind
+      -- See Note [Weird typing rule for ForAllTy] in Type
 
-    CoVarCo {}
-      -> mkKindCo co
+    FunCo _ _ _
+      -> ASSERT( False )
+         mkNomReflCo liftedTypeKind
 
-    AxiomInstCo {}
-      -> mkKindCo co
+    CoVarCo {}     -> mkKindCo co
+    HoleCo {}      -> mkKindCo co
+    AxiomInstCo {} -> mkKindCo co
+    AxiomRuleCo {} -> mkKindCo co
 
-    UnivCo UnsafeCoerceProv _ t1 t2
-      -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2)
-    UnivCo (PhantomProv kco) _ _ _
-      -> kco
-    UnivCo (ProofIrrelProv kco) _ _ _
-      -> kco
-    UnivCo (PluginProv _) _ _ _
-      -> mkKindCo co
-    UnivCo (HoleProv _) _ _ _
-      -> mkKindCo co
+    UnivCo UnsafeCoerceProv _ t1 t2   -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2)
+    UnivCo (PhantomProv kco) _ _ _    -> kco
+    UnivCo (ProofIrrelProv kco) _ _ _ -> kco
+    UnivCo (PluginProv _) _ _ _       -> mkKindCo co
 
     SymCo g
       -> mkSymCo (promoteCoercion g)
@@ -1208,7 +1333,7 @@ promoteCoercion co = case co of
     TransCo co1 co2
       -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)
 
-    NthCo n co1
+    NthCo _ n co1
       | Just (_, args) <- splitTyConAppCo_maybe co1
       , args `lengthExceeds` n
       -> promoteCoercion (args !! n)
@@ -1230,10 +1355,13 @@ promoteCoercion co = case co of
       -> mkKindCo co
 
     InstCo g _
-      -> promoteCoercion g
-
-    CoherenceCo g h
-      -> mkSymCo h `mkTransCo` promoteCoercion g
+      | isForAllTy_ty ty1
+      -> ASSERT( isForAllTy_ty ty2 )
+         promoteCoercion g
+      | otherwise
+      -> ASSERT( False)
+         mkNomReflCo liftedTypeKind
+           -- See Note [Weird typing rule for ForAllTy] in Type
 
     KindCo _
       -> ASSERT( False )
@@ -1242,9 +1370,6 @@ promoteCoercion co = case co of
     SubCo g
       -> promoteCoercion g
 
-    AxiomRuleCo {}
-      -> mkKindCo co
-
   where
     Pair ty1 ty2 = coercionKind co
     ki1 = typeKind ty1
@@ -1254,22 +1379,28 @@ promoteCoercion co = case co of
 -- where @g' = promoteCoercion (h w)@.
 -- fails if this is not possible, if @g@ coerces between a forall and an ->
 -- or if second parameter has a representational role and can't be used
--- with an InstCo. The result role matches is representational.
-instCoercion :: Pair Type -- type of the first coercion
-             -> Coercion  -- ^ must be nominal
+-- with an InstCo.
+instCoercion :: Pair Type -- g :: lty ~ rty
+             -> CoercionN  -- ^  must be nominal
              -> Coercion
-             -> Maybe Coercion
+             -> Maybe CoercionN
 instCoercion (Pair lty rty) g w
-  | isForAllTy lty && isForAllTy rty
-  , Just w' <- setNominalRole_maybe w
+  | (isForAllTy_ty lty && isForAllTy_ty rty)
+  || (isForAllTy_co lty && isForAllTy_co rty)
+  , Just w' <- setNominalRole_maybe (coercionRole w) w
+    -- g :: (forall t1. t2) ~ (forall t1. t3)
+    -- w :: s1 ~ s2
+    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]
   = Just $ mkInstCo g w'
   | isFunTy lty && isFunTy rty
-  = Just $ mkNthCo 3 g -- extract result type, which is the 4th argument to (->)
+    -- g :: (t1 -> t2) ~ (t3 -> t4)
+    -- returns t2 ~ t4
+  = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->)
   | otherwise -- one forall, one funty...
   = Nothing
-  where
 
-instCoercions :: Coercion -> [Coercion] -> Maybe Coercion
+-- | Repeated use of 'instCoercion'
+instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN
 instCoercions g ws
   = let arg_ty_pairs = map coercionKind ws in
     snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)
@@ -1281,11 +1412,24 @@ instCoercions g ws
            ; return (piResultTy <$> g_tys <*> w_tys, g') }
 
 -- | Creates a new coercion with both of its types casted by different casts
--- castCoercionKind g h1 h2, where g :: t1 ~ t2, has type (t1 |> h1) ~ (t2 |> h2)
--- The second and third coercions must be nominal.
-castCoercionKind :: Coercion -> Coercion -> Coercion -> Coercion
-castCoercionKind g h1 h2
-  = g `mkCoherenceLeftCo` h1 `mkCoherenceRightCo` h2
+-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,
+-- has type @(t1 |> h1) ~r (t2 |> h2)@.
+-- @h1@ and @h2@ must be nominal.
+castCoercionKind :: Coercion -> Role -> Type -> Type
+                 -> CoercionN -> CoercionN -> Coercion
+castCoercionKind g r t1 t2 h1 h2
+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)
+
+-- | Creates a new coercion with both of its types casted by different casts
+-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,
+-- has type @(t1 |> h1) ~r (t2 |> h2)@.
+-- @h1@ and @h2@ must be nominal.
+-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)
+-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand.
+castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion
+castCoercionKindI g h1 h2
+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)
+  where (Pair t1 t2, r) = coercionKindRole g
 
 -- See note [Newtype coercions] in TyCon
 
@@ -1293,27 +1437,38 @@ mkPiCos :: Role -> [Var] -> Coercion -> Coercion
 mkPiCos r vs co = foldr (mkPiCo r) co vs
 
 -- | Make a forall 'Coercion', where both types related by the coercion
--- are quantified over the same type variable.
+-- are quantified over the same variable.
 mkPiCo  :: Role -> Var -> Coercion -> Coercion
 mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co
+              | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) )
+                  -- We didn't call mkForAllCo here because if v does not appear
+                  -- in co, the argement coercion will be nominal. But here we
+                  -- want it to be r. It is only called in 'mkPiCos', which is
+                  -- only used in SimplUtils, where we are sure for
+                  -- now (Aug 2018) v won't occur in co.
+                            mkFunCo r (mkReflCo r (varType v)) co
               | otherwise = mkFunCo r (mkReflCo r (varType v)) co
 
--- The second coercion is sometimes lifted (~) and sometimes unlifted (~#).
--- So, we have to make sure to supply the right parameter to decomposeCo.
--- mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# s2) ~# (t1 ~# t2)) :: s2 ~# t2
--- Both coercions *must* have the same role.
-mkCoCast :: Coercion -> Coercion -> Coercion
+-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2
+-- The first coercion might be lifted or unlifted; thus the ~? above
+-- Lifted and unlifted equalities take different numbers of arguments,
+-- so we have to make sure to supply the right parameter to decomposeCo.
+-- Also, note that the role of the first coercion is the same as the role of
+-- the equalities related by the second coercion. The second coercion is
+-- itself always representational.
+mkCoCast :: Coercion -> CoercionR -> Coercion
 mkCoCast c g
+  | (g2:g1:_) <- reverse co_list
   = mkSymCo g1 `mkTransCo` c `mkTransCo` g2
+
+  | otherwise
+  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))
   where
-       -- g  :: (s1 ~# s2) ~# (t1 ~#  t2)
-       -- g1 :: s1 ~# t1
-       -- g2 :: s2 ~# t2
-    (_, args) = splitTyConApp (pFst $ coercionKind g)
-    n_args = length args
-    co_list = decomposeCo n_args g
-    g1 = co_list `getNth` (n_args - 2)
-    g2 = co_list `getNth` (n_args - 1)
+    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)
+    -- g1 :: s1 ~# s2
+    -- g2 :: t1 ~# t2
+    (tc, _) = splitTyConApp (pFst $ coercionKind g)
+    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)
 
 {-
 %************************************************************************
@@ -1468,8 +1623,8 @@ eqCoercionX env = eqTypeX env `on` coercionType
 Note [Lifting coercions over types: liftCoSubst]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The KPUSH rule deals with this situation
-   data T a = MkK (a -> Maybe a)
-   g :: T t1 ~ K t2
+   data T a = K (a -> Maybe a)
+   g :: T t1 ~ T t2
    x :: t1 -> Maybe t1
 
    case (K @t1 x) |> g of
@@ -1491,6 +1646,40 @@ thus giving *coercion*.  This is what liftCoSubst does.
 In the presence of kind coercions, this is a bit
 of a hairy operation. So, we refer you to the paper introducing kind coercions,
 available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf
+
+Note [extendLiftingContextEx]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider we have datatype
+  K :: \/k. \/a::k. P -> T k  -- P be some type
+  g :: T k1 ~ T k2
+
+  case (K @k1 @t1 x) |> g of
+    K y -> rhs
+
+We want to push the coercion inside the constructor application.
+We first get the coercion mapped by the universal type variable k:
+   lc = k |-> Nth 0 g :: k1~k2
+
+Here, the important point is that the kind of a is coerced, and P might be
+dependent on the existential type variable a.
+Thus we first get the coercion of a's kind
+   g2 = liftCoSubst lc k :: k1 ~ k2
+
+Then we store a new mapping into the lifting context
+   lc2 = a |-> (t1 ~ t1 |> g2), lc
+
+So later when we can correctly deal with the argument type P
+   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]
+
+This is exactly what extendLiftingContextEx does.
+* For each (tyvar:k, ty) pair, we product the mapping
+    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))
+* For each (covar:s1~s2, ty) pair, we produce the mapping
+    covar |-> (co ~ co')
+    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'
+
+This follows the lifting context extension definition in the
+"FC with Explicit Kind Equality" paper.
 -}
 
 -- ----------------------------------------------------
@@ -1508,21 +1697,21 @@ instance Outputable LiftingContext where
 type LiftCoEnv = VarEnv Coercion
      -- Maps *type variables* to *coercions*.
      -- That's the whole point of this function!
+     -- Also maps coercion variables to ProofIrrelCos.
 
 -- like liftCoSubstWith, but allows for existentially-bound types as well
 liftCoSubstWithEx :: Role          -- desired role for output coercion
                   -> [TyVar]       -- universally quantified tyvars
                   -> [Coercion]    -- coercions to substitute for those
-                  -> [TyVar]       -- existentially quantified tyvars
-                  -> [Type]        -- types to be bound to ex vars
+                  -> [TyCoVar]     -- existentially quantified tycovars
+                  -> [Type]        -- types and coercions to be bound to ex vars
                   -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args)
 liftCoSubstWithEx role univs omegas exs rhos
   = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas)
         psi   = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos)
-    in (ty_co_subst psi role, substTyVars (lcSubstRight psi) exs)
+    in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs))
 
 liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion
--- NB: This really can be called with CoVars, when optimising axioms.
 liftCoSubstWith r tvs cos ty
   = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty
 
@@ -1532,7 +1721,7 @@ liftCoSubstWith r tvs cos ty
 -- types of the mapped coercions in @lc@, and similar for @lc_right@.
 liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
 liftCoSubst r lc@(LC subst env) ty
-  | isEmptyVarEnv env = Refl r (substTy subst ty)
+  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)
   | otherwise         = ty_co_subst lc r ty
 
 emptyLiftingContext :: InScopeSet -> LiftingContext
@@ -1546,20 +1735,30 @@ mkLiftingContext pairs
 mkSubstLiftingContext :: TCvSubst -> LiftingContext
 mkSubstLiftingContext subst = LC subst emptyVarEnv
 
--- | Extend a lifting context with a new /type/ mapping.
+-- | Extend a lifting context with a new mapping.
 extendLiftingContext :: LiftingContext  -- ^ original LC
-                     -> TyVar           -- ^ new variable to map...
+                     -> TyCoVar         -- ^ new variable to map...
                      -> Coercion        -- ^ ...to this lifted version
                      -> LiftingContext
+    -- mappings to reflexive coercions are just substitutions
 extendLiftingContext (LC subst env) tv arg
-  = ASSERT( isTyVar tv )
-    LC subst (extendVarEnv env tv arg)
+  | Just (ty, _) <- isReflCo_maybe arg
+  = LC (extendTCvSubst subst tv ty) env
+  | otherwise
+  = LC subst (extendVarEnv env tv arg)
+
+-- | Extend a lifting context with a new mapping, and extend the in-scope set
+extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC
+                               -> TyCoVar         -- ^ new variable to map...
+                               -> Coercion        -- ^ to this coercion
+                               -> LiftingContext
+extendLiftingContextAndInScope (LC subst env) tv co
+  = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co
 
 -- | Extend a lifting context with existential-variable bindings.
--- This follows the lifting context extension definition in the
--- "FC with Explicit Kind Equality" paper.
+-- See Note [extendLiftingContextEx]
 extendLiftingContextEx :: LiftingContext    -- ^ original lifting context
-                       -> [(TyVar,Type)]    -- ^ ex. var / value pairs
+                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs
                        -> LiftingContext
 -- Note that this is more involved than extendLiftingContext. That function
 -- takes a coercion to extend with, so it's assumed that the caller has taken
@@ -1569,25 +1768,47 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)
 -- This function adds bindings for *Nominal* coercions. Why? Because it
 -- works with existentially bound variables, which are considered to have
 -- nominal roles.
+  | isTyVar v
   = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty)
-                 (extendVarEnv env v (mkSymCo $ mkCoherenceCo
-                                         (mkNomReflCo ty)
-                                         (ty_co_subst lc Nominal (tyVarKind v))))
+                 (extendVarEnv env v $
+                  mkGReflRightCo Nominal
+                                 ty
+                                 (ty_co_subst lc Nominal (tyVarKind v)))
     in extendLiftingContextEx lc' rest
+  | CoercionTy co <- ty
+  = -- co      :: s1 ~r s2
+    -- lift_s1 :: s1 ~r s1'
+    -- lift_s2 :: s2 ~r s2'
+    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')
+    ASSERT( isCoVar v )
+    let (_, _, s1, s2, r) = coVarKindsTypesRole v
+        lift_s1 = ty_co_subst lc r s1
+        lift_s2 = ty_co_subst lc r s2
+        kco     = mkTyConAppCo Nominal (equalityTyCon r)
+                               [ mkKindCo lift_s1, mkKindCo lift_s2
+                               , lift_s1         , lift_s2          ]
+        lc'     = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co)
+                     (extendVarEnv env v
+                        (mkProofIrrelCo Nominal kco co $
+                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))
+    in extendLiftingContextEx lc' rest
+  | otherwise
+  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)
+
 
 -- | Erase the environments in a lifting context
 zapLiftingContext :: LiftingContext -> LiftingContext
 zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv
 
 -- | Like 'substForAllCoBndr', but works on a lifting context
-substForAllCoBndrCallbackLC :: Bool
+substForAllCoBndrUsingLC :: Bool
                             -> (Coercion -> Coercion)
-                            -> LiftingContext -> TyVar -> Coercion
-                            -> (LiftingContext, TyVar, Coercion)
-substForAllCoBndrCallbackLC sym sco (LC subst lc_env) tv co
+                            -> LiftingContext -> TyCoVar -> Coercion
+                            -> (LiftingContext, TyCoVar, Coercion)
+substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
   = (LC subst' lc_env, tv', co')
   where
-    (subst', tv', co') = substForAllCoBndrCallback sym sco subst tv co
+    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co
 
 -- | The \"lifting\" operation which substitutes coercions for type
 --   variables in a type to produce a coercion.
@@ -1598,19 +1819,21 @@ ty_co_subst lc role ty
   = go role ty
   where
     go :: Role -> Type -> Coercion
+    go r ty                | Just ty' <- coreView ty
+                           = go r ty'
     go Phantom ty          = lift_phantom ty
     go r (TyVarTy tv)      = expectJust "ty_co_subst bad roles" $
                              liftCoSubstTyVar lc r tv
     go r (AppTy ty1 ty2)   = mkAppCo (go r ty1) (go Nominal ty2)
     go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys)
     go r (FunTy ty1 ty2)   = mkFunCo r (go r ty1) (go r ty2)
-    go r (ForAllTy (TvBndr v _) ty)
+    go r (ForAllTy (Bndr v _) ty)
                            = let (lc', v', h) = liftCoSubstVarBndr lc v in
                              mkForAllCo v' h $! ty_co_subst lc' r ty
     go r ty@(LitTy {})     = ASSERT( r == Nominal )
-                             mkReflCo r ty
-    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)
-                                                        (substRightCo lc co)
+                             mkNomReflCo ty
+    go r (CastTy ty co)    = castCoercionKindI (go r ty) (substLeftCo lc co)
+                                                         (substRightCo lc co)
     go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)
                                                   (substRightCo lc co)
       where kco = go Nominal (coercionType co)
@@ -1639,22 +1862,71 @@ liftCoSubstTyVar (LC subst env) r v
   = downgradeRole_maybe r (coercionRole co_arg) co_arg
 
   | otherwise
-  = Just $ Refl r (substTyVar subst v)
+  = Just $ mkReflCo r (substTyVar subst v)
+
+{- Note [liftCoSubstVarBndr]
+
+callback:
+  We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in
+  FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type
+  in snd.
+  However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and
+  ignore the fourth componenet of the return value.
+
+liftCoSubstTyVarBndrUsing:
+  Given
+    forall tv:k. t
+  We want to get
+    forall (tv:k1) (kind_co :: k1 ~ k2) body_co
+
+  We lift the kind k to get the kind_co
+    kind_co = ty_co_subst k :: k1 ~ k2
+
+  Now in the LiftingContext, we add the new mapping
+    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)
+
+liftCoSubstCoVarBndrUsing:
+  Given
+    forall cv:(s1 ~ s2). t
+  We want to get
+    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co
+
+  We lift s1 and s2 respectively to get
+    eta1 :: s1' ~ t1
+    eta2 :: s2' ~ t2
+  And
+    kind_co = TyConAppCo Nominal (~#) eta1 eta2
+
+  Now in the liftingContext, we add the new mapping
+    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)
+-}
 
-liftCoSubstVarBndr :: LiftingContext -> TyVar
-                   -> (LiftingContext, TyVar, Coercion)
+-- See Note [liftCoSubstVarBndr]
+liftCoSubstVarBndr :: LiftingContext -> TyCoVar
+                   -> (LiftingContext, TyCoVar, Coercion)
 liftCoSubstVarBndr lc tv
-  = let (lc', tv', h, _) = liftCoSubstVarBndrCallback callback lc tv in
+  = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in
     (lc', tv', h)
   where
     callback lc' ty' = (ty_co_subst lc' Nominal ty', ())
 
 -- the callback must produce a nominal coercion
-liftCoSubstVarBndrCallback :: (LiftingContext -> Type -> (Coercion, a))
+liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
+                           -> LiftingContext -> TyCoVar
+                           -> (LiftingContext, TyCoVar, CoercionN, a)
+liftCoSubstVarBndrUsing fun lc old_var
+  | isTyVar old_var
+  = liftCoSubstTyVarBndrUsing fun lc old_var
+  | otherwise
+  = liftCoSubstCoVarBndrUsing fun lc old_var
+
+-- Works for tyvar binder
+liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
                            -> LiftingContext -> TyVar
-                           -> (LiftingContext, TyVar, Coercion, a)
-liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var
-  = ( LC (subst `extendTCvInScope` new_var) new_cenv
+                           -> (LiftingContext, TyVar, CoercionN, a)
+liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var
+  = ASSERT( isTyVar old_var )
+    ( LC (subst `extendTCvInScope` new_var) new_cenv
     , new_var, eta, stuff )
   where
     old_kind     = tyVarKind old_var
@@ -1662,7 +1934,45 @@ liftCoSubstVarBndrCallback fun lc@(LC subst cenv) old_var
     Pair k1 _    = coercionKind eta
     new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)
 
-    lifted   = Refl Nominal (TyVarTy new_var)
+    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta
+               -- :: new_var ~ new_var |> eta
+    new_cenv = extendVarEnv cenv old_var lifted
+
+-- Works for covar binder
+liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a))
+                           -> LiftingContext -> CoVar
+                           -> (LiftingContext, CoVar, CoercionN, a)
+liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var
+  = ASSERT( isCoVar old_var )
+    ( LC (subst `extendTCvInScope` new_var) new_cenv
+    , new_var, kind_co, stuff )
+  where
+    old_kind     = coVarKind old_var
+    (eta, stuff) = fun lc old_kind
+    Pair k1 _    = coercionKind eta
+    new_var      = uniqAway (getTCvInScope subst) (setVarType old_var k1)
+
+    -- old_var :: s1  ~r s2
+    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)
+    -- eta1    :: s1' ~r t1
+    -- eta2    :: s2' ~r t2
+    -- co1     :: s1' ~r s2'
+    -- co2     :: t1  ~r t2
+    -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2)
+    -- lifted  :: co1 ~N co2
+
+    role   = coVarRole old_var
+    eta'   = downgradeRole role Nominal eta
+    eta1   = mkNthCo role 2 eta'
+    eta2   = mkNthCo role 3 eta'
+
+    co1     = mkCoVarCo new_var
+    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2
+    kind_co = mkTyConAppCo Nominal (equalityTyCon role)
+                           [ mkKindCo co1, mkKindCo co2
+                           , co1         , co2          ]
+    lifted  = mkProofIrrelCo Nominal kind_co co1 co2
+
     new_cenv = extendVarEnv cenv old_var lifted
 
 -- | Is a var in the domain of a lifting context?
@@ -1733,23 +2043,28 @@ lcInScopeSet (LC subst _) = getTCvInScope subst
 %************************************************************************
 -}
 
+seqMCo :: MCoercion -> ()
+seqMCo MRefl    = ()
+seqMCo (MCo co) = seqCo co
+
 seqCo :: Coercion -> ()
-seqCo (Refl r ty)               = r `seq` seqType ty
+seqCo (Refl ty)                 = seqType ty
+seqCo (GRefl r ty mco)          = r `seq` seqType ty `seq` seqMCo mco
 seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos
 seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2
-seqCo (ForAllCo tv k co)        = seqType (tyVarKind tv) `seq` seqCo k
-                                                         `seq` seqCo co
+seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k
+                                                       `seq` seqCo co
 seqCo (FunCo r co1 co2)         = r `seq` seqCo co1 `seq` seqCo co2
 seqCo (CoVarCo cv)              = cv `seq` ()
+seqCo (HoleCo h)                = coHoleCoVar h `seq` ()
 seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos
 seqCo (UnivCo p r t1 t2)
   = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2
 seqCo (SymCo co)                = seqCo co
 seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2
-seqCo (NthCo n co)              = n `seq` seqCo co
+seqCo (NthCo r n co)            = r `seq` n `seq` seqCo co
 seqCo (LRCo lr co)              = lr `seq` seqCo co
 seqCo (InstCo co arg)           = seqCo co `seq` seqCo arg
-seqCo (CoherenceCo co1 co2)     = seqCo co1 `seq` seqCo co2
 seqCo (KindCo co)               = seqCo co
 seqCo (SubCo co)                = seqCo co
 seqCo (AxiomRuleCo _ cs)        = seqCos cs
@@ -1759,7 +2074,6 @@ seqProv UnsafeCoerceProv    = ()
 seqProv (PhantomProv co)    = seqCo co
 seqProv (ProofIrrelProv co) = seqCo co
 seqProv (PluginProv _)      = ()
-seqProv (HoleProv _)        = ()
 
 seqCos :: [Coercion] -> ()
 seqCos []       = ()
@@ -1771,19 +2085,6 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos
              The kind of a type, and of a coercion
 %*                                                                      *
 %************************************************************************
-
-Note [Computing a coercion kind and role]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To compute a coercion's kind is straightforward: see coercionKind.
-But to compute a coercion's role, in the case for NthCo we need
-its kind as well.  So if we have two separate functions (one for kinds
-and one for roles) we can get exponentially bad behaviour, since each
-NthCo node makes a separate call to coercionKind, which traverses the
-sub-tree again.  This was part of the problem in Trac #9233.
-
-Solution: compute both together; hence coercionKindRole.  We keep a
-separate coercionKind function because it's a bit more efficient if
-the kind is all you want.
 -}
 
 coercionType :: Coercion -> Type
@@ -1798,24 +2099,23 @@ coercionType co = case coercionKindRole co of
 -- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
 
 coercionKind :: Coercion -> Pair Type
-coercionKind co = go co
+coercionKind co =
+  go co
   where
-    go (Refl _ ty)          = Pair ty ty
+    go (Refl ty) = Pair ty ty
+    go (GRefl _ ty MRefl) = Pair ty ty
+    go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1)
     go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos)
     go (AppCo co1 co2)      = mkAppTy <$> go co1 <*> go co2
-    go (ForAllCo tv1 k_co co)
-      = let Pair _ k2          = go k_co
-            tv2                = setTyVarKind tv1 k2
-            Pair ty1 ty2       = go co
-            subst = zipTvSubst [tv1] [TyVarTy tv2 `mk_cast_ty` mkSymCo k_co]
-            ty2' = substTyAddInScope subst ty2 in
-            -- We need free vars of ty2 in scope to satisfy the invariant
-            -- from Note [The substitution invariant]
-            -- This is doing repeated substitutions and probably doesn't
-            -- need to, see #11735
-        mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2'
+    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar
+       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 <$> go co1
+         -- kind_co always has kind @Type@, thus @isGReflCo@
+       | otherwise                = go_forall empty_subst co
+       where
+         empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co)
     go (FunCo _ co1 co2)    = mkFunTy <$> go co1 <*> go co2
     go (CoVarCo cv)         = coVarTypes cv
+    go (HoleCo h)           = coVarTypes (coHoleCoVar h)
     go (AxiomInstCo ax ind cos)
       | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
                    , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind
@@ -1835,7 +2135,7 @@ coercionKind co = go co
     go (UnivCo _ _ ty1 ty2)   = Pair ty1 ty2
     go (SymCo co)             = swap $ go co
     go (TransCo co1 co2)      = Pair (pFst $ go co1) (pSnd $ go co2)
-    go g@(NthCo d co)
+    go g@(NthCo _ d co)
       | Just argss <- traverse tyConAppArgs_maybe tys
       = ASSERT( and $ (`lengthExceeds` d) <$> argss )
         (`getNth` d) <$> argss
@@ -1850,9 +2150,6 @@ coercionKind co = go co
         tys = go co
     go (LRCo lr co)         = (pickLR lr . splitAppTy) <$> go co
     go (InstCo aco arg)     = go_app aco [arg]
-    go (CoherenceCo g h)
-      = let Pair ty1 ty2 = go g in
-        Pair (mkCastTy ty1 h) ty2
     go (KindCo co)          = typeKind <$> go co
     go (SubCo co)           = go co
     go (AxiomRuleCo ax cos) = expectJust "coercionKind" $
@@ -1864,84 +2161,92 @@ coercionKind co = go co
     go_app (InstCo co arg) args = go_app co (arg:args)
     go_app co              args = piResultTys <$> go co <*> (sequenceA $ map go args)
 
-    -- The real mkCastTy is too slow, and we can easily have nested ForAllCos.
-    mk_cast_ty :: Type -> Coercion -> Type
-    mk_cast_ty ty (Refl {}) = ty
-    mk_cast_ty ty co        = CastTy ty co
+    go_forall subst (ForAllCo tv1 k_co co)
+      -- See Note [Nested ForAllCos]
+      | isTyVar tv1
+      = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co
+      where
+        Pair _ k2 = go k_co
+        tv2       = setTyVarKind tv1 (substTy subst k2)
+        subst' | isGReflCo k_co = extendTCvInScope subst tv1
+                 -- kind_co always has kind @Type@, thus @isGReflCo@
+               | otherwise      = extendTvSubst (extendTCvInScope subst tv2) tv1 $
+                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co
+    go_forall subst (ForAllCo cv1 k_co co)
+      | isCoVar cv1
+      = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co
+      where
+        Pair _ k2 = go k_co
+        r         = coVarRole cv1
+        eta1      = mkNthCo r 2 (downgradeRole r Nominal k_co)
+        eta2      = mkNthCo r 3 (downgradeRole r Nominal k_co)
+
+        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)
+        -- k1    = t1 ~r t2
+        -- k2    = s1 ~r s2
+        -- cv1  :: t1 ~r t2
+        -- cv2  :: s1 ~r s2
+        -- eta1 :: t1 ~r s1
+        -- eta2 :: t2 ~r s2
+        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2
+
+        cv2     = setVarType cv1 (substTy subst k2)
+        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)
+        subst'  | isReflCo k_co = extendTCvInScope subst cv1
+                | otherwise     = extendCvSubst (extendTCvInScope subst cv2)
+                                                cv1 n_subst
+
+    go_forall subst other_co
+      -- when other_co is not a ForAllCo
+      = substTy subst `pLiftSnd` go other_co
+
+{-
+
+Note [Nested ForAllCos]
+~~~~~~~~~~~~~~~~~~~~~~~
+
+Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an
+co)...) )`.   We do not want to perform `n` single-type-variable
+substitutions over the kind of `co`; rather we want to do one substitution
+which substitutes for all of `a1`, `a2` ... simultaneously.  If we do one
+at a time we get the performance hole reported in Trac #11735.
+
+Solution: gather up the type variables for nested `ForAllCos`, and
+substitute for them all at once.  Remarkably, for Trac #11735 this single
+change reduces /total/ compile time by a factor of more than ten.
+
+-}
 
 -- | Apply 'coercionKind' to multiple 'Coercion's
 coercionKinds :: [Coercion] -> Pair [Type]
 coercionKinds tys = sequenceA $ map coercionKind tys
 
 -- | Get a coercion's kind and role.
--- Why both at once?  See Note [Computing a coercion kind and role]
 coercionKindRole :: Coercion -> (Pair Type, Role)
-coercionKindRole = go
-  where
-    go (Refl r ty) = (Pair ty ty, r)
-    go (TyConAppCo r tc cos)
-      = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r)
-    go (AppCo co1 co2)
-      = let (tys1, r1) = go co1 in
-        (mkAppTy <$> tys1 <*> coercionKind co2, r1)
-    go (ForAllCo tv1 k_co co)
-      = let Pair _ k2          = coercionKind k_co
-            tv2                = setTyVarKind tv1 k2
-            (Pair ty1 ty2, r)  = go co
-            subst = zipTvSubst [tv1] [TyVarTy tv2 `mkCastTy` mkSymCo k_co]
-            ty2' = substTyAddInScope subst ty2 in
-            -- We need free vars of ty2 in scope to satisfy the invariant
-            -- from Note [The substitution invariant]
-            -- This is doing repeated substitutions and probably doesn't
-            -- need to, see #11735
-        (mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2', r)
-    go (FunCo r co1 co2)
-      = (mkFunTy <$> coercionKind co1 <*> coercionKind co2, r)
-    go (CoVarCo cv) = (coVarTypes cv, coVarRole cv)
-    go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax)
-    go (UnivCo _ r ty1 ty2)  = (Pair ty1 ty2, r)
-    go (SymCo co) = first swap $ go co
-    go (TransCo co1 co2)
-      = let (tys1, r) = go co1 in
-        (Pair (pFst tys1) (pSnd $ coercionKind co2), r)
-    go (NthCo d co)
-      | Just (tv1, _) <- splitForAllTy_maybe ty1
-      = ASSERT( d == 0 )
-        let (tv2, _) = splitForAllTy ty2 in
-        (tyVarKind <$> Pair tv1 tv2, Nominal)
-
-      | otherwise
-      = let (tc1,  args1) = splitTyConApp ty1
-            (_tc2, args2) = splitTyConApp ty2
-        in
-        ASSERT2( tc1 == _tc2, ppr d $$ ppr tc1 $$ ppr _tc2 )
-        ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d)
-
-      where
-        (Pair ty1 ty2, r) = go co
-    go co@(LRCo {}) = (coercionKind co, Nominal)
-    go (InstCo co arg) = go_app co [arg]
-    go (CoherenceCo co1 co2)
-      = let (Pair t1 t2, r) = go co1 in
-        (Pair (t1 `mkCastTy` co2) t2, r)
-    go co@(KindCo {}) = (coercionKind co, Nominal)
-    go (SubCo co) = (coercionKind co, Representational)
-    go co@(AxiomRuleCo ax _) = (coercionKind co, coaxrRole ax)
-
-    go_app :: Coercion -> [Coercion] -> (Pair Type, Role)
-    -- Collect up all the arguments and apply all at once
-    -- See Note [Nested InstCos]
-    go_app (InstCo co arg) args = go_app co (arg:args)
-    go_app co              args
-      = let (pair, r) = go co in
-        (piResultTys <$> pair <*> (sequenceA $ map coercionKind args), r)
+coercionKindRole co = (coercionKind co, coercionRole co)
 
 -- | Retrieve the role from a coercion.
 coercionRole :: Coercion -> Role
-coercionRole = snd . coercionKindRole
-  -- There's not a better way to do this, because NthCo needs the *kind*
-  -- and role of its argument. Luckily, laziness should generally avoid
-  -- the need for computing kinds in other cases.
+coercionRole = go
+  where
+    go (Refl _) = Nominal
+    go (GRefl r _ _) = r
+    go (TyConAppCo r _ _) = r
+    go (AppCo co1 _) = go co1
+    go (ForAllCo _ _ co) = go co
+    go (FunCo r _ _) = r
+    go (CoVarCo cv) = coVarRole cv
+    go (HoleCo h)   = coVarRole (coHoleCoVar h)
+    go (AxiomInstCo ax _ _) = coAxiomRole ax
+    go (UnivCo _ r _ _)  = r
+    go (SymCo co) = go co
+    go (TransCo co1 _co2) = go co1
+    go (NthCo r _d _co) = r
+    go (LRCo {}) = Nominal
+    go (InstCo co _) = go co
+    go (KindCo {}) = Nominal
+    go (SubCo _) = Representational
+    go (AxiomRuleCo ax _) = coaxrRole ax
 
 {-
 Note [Nested InstCos]
@@ -1959,3 +2264,94 @@ So it's very important to do the substitution simultaneously;
 cf Type.piResultTys (which in fact we call here).
 
 -}
+
+-- | Assuming that two types are the same, ignoring coercions, find
+-- a nominal coercion between the types. This is useful when optimizing
+-- transitivity over coercion applications, where splitting two
+-- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion.
+buildCoercion :: Type -> Type -> CoercionN
+buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
+               | Just ty2' <- coreView ty2 = go ty1 ty2'
+
+    go (CastTy ty1 co) ty2
+      = let co' = go ty1 ty2
+            r = coercionRole co'
+        in  mkCoherenceLeftCo r ty1 co co'
+
+    go ty1 (CastTy ty2 co)
+      = let co' = go ty1 ty2
+            r = coercionRole co'
+        in  mkCoherenceRightCo r ty2 co co'
+
+    go ty1@(TyVarTy tv1) _tyvarty
+      = ASSERT( case _tyvarty of
+                  { TyVarTy tv2 -> tv1 == tv2
+                  ; _           -> False      } )
+        mkNomReflCo ty1
+
+    go (FunTy arg1 res1) (FunTy arg2 res2)
+      = mkFunCo Nominal (go arg1 arg2) (go res1 res2)
+
+    go (TyConApp tc1 args1) (TyConApp tc2 args2)
+      = ASSERT( tc1 == tc2 )
+        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)
+
+    go (AppTy ty1a ty1b) ty2
+      | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2
+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)
+
+    go ty1 (AppTy ty2a ty2b)
+      | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1
+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)
+
+    go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)
+      | isTyVar tv1
+      = ASSERT( isTyVar tv2 )
+        mkForAllCo tv1 kind_co (go ty1 ty2')
+      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)
+            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
+            ty2'     = substTyWithInScope in_scope [tv2]
+                         [mkTyVarTy tv1 `mkCastTy` kind_co]
+                         ty2
+
+    go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)
+      = ASSERT( isCoVar cv1 && isCoVar cv2 )
+        mkForAllCo cv1 kind_co (go ty1 ty2')
+      where s1 = varType cv1
+            s2 = varType cv2
+            kind_co = go s1 s2
+
+            -- s1 = t1 ~r t2
+            -- s2 = t3 ~r t4
+            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)
+            -- eta1 :: t1 ~r t3
+            -- eta2 :: t2 ~r t4
+
+            r    = coVarRole cv1
+            kind_co' = downgradeRole r Nominal kind_co
+            eta1 = mkNthCo r 2 kind_co'
+            eta2 = mkNthCo r 3 kind_co'
+
+            subst = mkEmptyTCvSubst $ mkInScopeSet $
+                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
+            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`
+                                                       mkCoVarCo cv1 `mkTransCo`
+                                                       eta2)
+                            ty2
+
+    go ty1@(LitTy lit1) _lit2
+      = ASSERT( case _lit2 of
+                  { LitTy lit2 -> lit1 == lit2
+                  ; _          -> False        } )
+        mkNomReflCo ty1
+
+    go (CoercionTy co1) (CoercionTy co2)
+      = mkProofIrrelCo Nominal kind_co co1 co2
+      where
+        kind_co = go (coercionType co1) (coercionType co2)
+
+    go ty1 ty2
+      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2
+                                           , ppr ty1, ppr ty2 ])
diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot
index dd10d6e5ca..89aab441de 100644
--- a/compiler/types/Coercion.hs-boot
+++ b/compiler/types/Coercion.hs-boot
@@ -2,13 +2,14 @@
 
 module Coercion where
 
+import GhcPrelude
+
 import {-# SOURCE #-} TyCoRep
 import {-# SOURCE #-} TyCon
 
 import BasicTypes ( LeftOrRight )
 import CoAxiom
 import Var
-import Outputable
 import Pair
 import Util
 
@@ -24,19 +25,21 @@ mkUnsafeCo :: Role -> Type -> Type -> Coercion
 mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
 mkSymCo :: Coercion -> Coercion
 mkTransCo :: Coercion -> Coercion -> Coercion
-mkNthCo :: Int -> Coercion -> Coercion
+mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion
 mkLRCo :: LeftOrRight -> Coercion -> Coercion
 mkInstCo :: Coercion -> Coercion -> Coercion
-mkCoherenceCo :: Coercion -> Coercion -> Coercion
+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
+mkNomReflCo :: Type -> Coercion
 mkKindCo :: Coercion -> Coercion
 mkSubCo :: Coercion -> Coercion
 mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
+mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
 
-mkFunCos :: Role -> [Coercion] -> Coercion -> Coercion
-
+isGReflCo :: Coercion -> Bool
 isReflCo :: Coercion -> Bool
 isReflexiveCo :: Coercion -> Bool
-coVarKindsTypesRole :: CoVar -> (Kind, Kind, Type, Type, Role)
+decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)
+coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role)
 coVarRole :: CoVar -> Role
 
 mkCoercionType :: Role -> Type -> Type -> Type
@@ -47,5 +50,3 @@ seqCo :: Coercion -> ()
 
 coercionKind :: Coercion -> Pair Type
 coercionType :: Coercion -> Type
-
-pprCo :: Coercion -> SDoc
diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index 6d179a9a10..a5cfba1afb 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -2,7 +2,7 @@
 --
 -- FamInstEnv: Type checked family instance declarations
 
-{-# LANGUAGE CPP, GADTs, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns #-}
 
 module FamInstEnv (
         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
@@ -29,9 +29,8 @@ module FamInstEnv (
 
         -- Normalisation
         topNormaliseType, topNormaliseType_maybe,
-        normaliseType, normaliseTcApp,
+        normaliseType, normaliseTcApp, normaliseTcArgs,
         reduceTyFamApp_maybe,
-        pmTopNormaliseType_maybe,
 
         -- Flattening
         flattenTys
@@ -39,11 +38,12 @@ module FamInstEnv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Unify
 import Type
 import TyCoRep
 import TyCon
-import DataCon (DataCon)
 import Coercion
 import CoAxiom
 import VarSet
@@ -53,7 +53,7 @@ import PrelNames ( eqPrimTyConKey )
 import UniqDFM
 import Outputable
 import Maybes
-import TrieMap
+import CoreMap
 import Unique
 import Util
 import Var
@@ -62,7 +62,8 @@ import SrcLoc
 import FastString
 import MonadUtils
 import Control.Monad
-import Data.List( mapAccumL, find )
+import Data.List( mapAccumL )
+import Data.Array( Array, assocs )
 
 {-
 ************************************************************************
@@ -125,8 +126,50 @@ data FamFlavor
   = SynFamilyInst         -- A synonym family
   | DataFamilyInst TyCon  -- A data family, with its representation TyCon
 
-{- Note [Eta reduction for data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{-
+Note [Arity of data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Data family instances might legitimately be over- or under-saturated.
+
+Under-saturation has two potential causes:
+ U1) Eta reduction. See Note [Eta reduction for data families].
+ U2) When the user has specified a return kind instead of written out patterns.
+     Example:
+
+       data family Sing (a :: k)
+       data instance Sing :: Bool -> Type
+
+     The data family tycon Sing has an arity of 2, the k and the a. But
+     the data instance has only one pattern, Bool (standing in for k).
+     This instance is equivalent to `data instance Sing (a :: Bool)`, but
+     without the last pattern, we have an under-saturated data family instance.
+     On its own, this example is not compelling enough to add support for
+     under-saturation, but U1 makes this feature more compelling.
+
+Over-saturation is also possible:
+  O1) If the data family's return kind is a type variable (see also #12369),
+      an instance might legitimately have more arguments than the family.
+      Example:
+
+        data family Fix :: (Type -> k) -> k
+        data instance Fix f = MkFix1 (f (Fix f))
+        data instance Fix f x = MkFix2 (f (Fix f x) x)
+
+      In the first instance here, the k in the data family kind is chosen to
+      be Type. In the second, it's (Type -> Type).
+
+      However, we require that any over-saturation is eta-reducible. That is,
+      we require that any extra patterns be bare unrepeated type variables;
+      see Note [Eta reduction for data families]. Accordingly, the FamInst
+      is never over-saturated.
+
+Why can we allow such flexibility for data families but not for type families?
+Because data families can be decomposed -- that is, they are generative and
+injective. A Type family is neither and so always must be applied to all its
+arguments.
+
+Note [Eta reduction for data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this
    data family T a b :: *
    newtype instance T Int a = MkT (IO a) deriving( Monad )
@@ -148,22 +191,31 @@ Solution: eta-reduce both axioms, thus:
 Now
    d' = d |> Monad (sym (ax2 ; ax1))
 
-This eta reduction happens for data instances as well as newtype
-instances. Here we want to eta-reduce the data family axiom.
-All this is done in TcInstDcls.tcDataFamInstDecl.
+----- Bottom line ------
+
+For a FamInst with fi_flavour = DataFamilyInst rep_tc,
 
-See also Note [Newtype eta] in TyCon.
+  - fi_tvs (and cab_tvs of its CoAxiom) may be shorter
+    than tyConTyVars of rep_tc.
 
-Bottom line:
-  For a FamInst with fi_flavour = DataFamilyInst rep_tc,
-  - fi_tvs may be shorter than tyConTyVars of rep_tc
   - fi_tys may be shorter than tyConArity of the family tycon
        i.e. LHS is unsaturated
+
   - fi_rhs will be (rep_tc fi_tvs)
        i.e. RHS is un-saturated
 
-  But when fi_flavour = SynFamilyInst,
+  - This eta reduction happens for data instances as well
+    as newtype instances. Here we want to eta-reduce the data family axiom.
+
+  - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl.
+
+But when fi_flavour = SynFamilyInst,
   - fi_tys has the exact arity of the family tycon
+
+
+(See also Note [Newtype eta] in TyCon.  This is notionally separate
+and deals with the axiom connecting a newtype with its representation
+type; but it too is eta-reduced.)
 -}
 
 -- Obtain the axiom of a family instance
@@ -219,7 +271,7 @@ instance Outputable FamInst where
 --     See pprTyThing.pprFamInst for printing for the user
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
-  = hang (pprFamInstHdr famInst) 2 (ifPprDebug debug_stuff)
+  = hang (pprFamInstHdr famInst) 2 (whenPprDebug debug_stuff)
   where
     ax = fi_axiom famInst
     debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax
@@ -415,7 +467,7 @@ familyInstances (pkg_fie, home_fie) fam
                 Nothing                      -> []
 
 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
-extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
+extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis
 
 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
 extendFamInstEnv inst_env
@@ -469,7 +521,7 @@ go back to all previous equations and check that, under the
 substitution induced by the match, other branches are surely apart. (See
 Note [Apartness].) This is similar to what happens with class
 instance selection, when we need to guarantee that there is only a match and
-no unifiers. The exact algorithm is different here because the the
+no unifiers. The exact algorithm is different here because the
 potentially-overlapping group is closed.
 
 As another example, consider this:
@@ -603,8 +655,8 @@ mkCoAxBranch tvs cvs lhs rhs roles loc
                , cab_loc     = loc
                , cab_incomps = placeHolderIncomps }
   where
-    (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs
-    (env,  cvs1) = tidyTyCoVarBndrs env1         cvs
+    (env1, tvs1) = tidyVarBndrs emptyTidyEnv tvs
+    (env,  cvs1) = tidyVarBndrs env1         cvs
     -- See Note [Tidy axioms when we build them]
 
 -- all of the following code is here to avoid mutual dependencies with
@@ -932,7 +984,6 @@ lookup_fam_inst_env' match_fun ie fam match_tys
         -- No match => try next
       | otherwise
       = find rest
-
       where
         (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys
 
@@ -1079,21 +1130,25 @@ chooseBranch axiom tys
              (target_tys, extra_tys) = splitAt num_pats tys
              branches = coAxiomBranches axiom
        ; (ind, inst_tys, inst_cos)
-           <- findBranch (fromBranches branches) target_tys
+           <- findBranch (unMkBranches branches) target_tys
        ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }
 
 -- The axiom must *not* be oversaturated
-findBranch :: [CoAxBranch]             -- branches to check
-           -> [Type]                   -- target types
+findBranch :: Array BranchIndex CoAxBranch
+           -> [Type]
            -> Maybe (BranchIndex, [Type], [Coercion])
     -- coercions relate requested types to returned axiom LHS at role N
 findBranch branches target_tys
-  = go 0 branches
+  = foldr go Nothing (assocs branches)
   where
-    go ind (branch@(CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs
-                               , cab_lhs = tpl_lhs
-                               , cab_incomps = incomps }) : rest)
-      = let in_scope = mkInScopeSet (unionVarSets $
+    go :: (BranchIndex, CoAxBranch)
+       -> Maybe (BranchIndex, [Type], [Coercion])
+       -> Maybe (BranchIndex, [Type], [Coercion])
+    go (index, branch) other
+      = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs
+                        , cab_lhs = tpl_lhs
+                        , cab_incomps = incomps }) = branch
+            in_scope = mkInScopeSet (unionVarSets $
                             map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
             -- See Note [Flattening] below
             flattened_target = flattenTys in_scope target_tys
@@ -1103,13 +1158,10 @@ findBranch branches target_tys
           -> -- matching worked & we're apart from all incompatible branches.
              -- success
              ASSERT( all (isJust . lookupCoVar subst) tpl_cvs )
-             Just (ind, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
+             Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
 
         -- failure. keep looking
-        _ -> go (ind+1) rest
-
-    -- fail if no branches left
-    go _ [] = Nothing
+        _ -> other
 
 -- | Do an apartness check, as described in the "Closed Type Families" paper
 -- (POPL '14). This should be used when determining if an equation
@@ -1162,7 +1214,7 @@ Type) pairs.
 
 We also benefit because we can piggyback on the liftCoSubstVarBndr function to
 deal with binders. However, I had to modify that function to work with this
-application. Thus, we now have liftCoSubstVarBndrCallback, which takes
+application. Thus, we now have liftCoSubstVarBndrUsing, which takes
 a function used to process the kind of the binder. We don't wish
 to lift the kind, but instead normalise it. So, we pass in a callback function
 that processes the kind of the binder.
@@ -1221,125 +1273,11 @@ topNormaliseType_maybe env ty
 
     tyFamStepper rec_nts tc tys  -- Try to step a type/data family
       = let (args_co, ntys) = normaliseTcArgs env Representational tc tys in
-          -- NB: It's OK to use normaliseTcArgs here instead of
-          -- normalise_tc_args (which takes the LiftingContext described
-          -- in Note [Normalising types]) because the reduceTyFamApp below
-          -- works only at top level. We'll never recur in this function
-          -- after reducing the kind of a bound tyvar.
-
         case reduceTyFamApp_maybe env Representational tc ntys of
           Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co)
           _              -> NS_Done
 
 ---------------
-pmTopNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Type, [DataCon], Type)
--- ^ Get rid of *outermost* (or toplevel)
---      * type function redex
---      * data family redex
---      * newtypes
---
--- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a
--- coercion, it returns useful information for issuing pattern matching
--- warnings. See Note [Type normalisation for EmptyCase] for details.
-pmTopNormaliseType_maybe env typ
-  = do ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ
-       return (eq_src_ty ty (typ : ty_f [ty]), tm_f [], ty)
-  where
-    -- Find the first type in the sequence of rewrites that is a data type,
-    -- newtype, or a data family application (not the representation tycon!).
-    -- This is the one that is equal (in source Haskell) to the initial type.
-    -- If none is found in the list, then all of them are type family
-    -- applications, so we simply return the last one, which is the *simplest*.
-    eq_src_ty :: Type -> [Type] -> Type
-    eq_src_ty ty tys = maybe ty id (find is_alg_or_data_family tys)
-
-    is_alg_or_data_family :: Type -> Bool
-    is_alg_or_data_family ty = isClosedAlgType ty || isDataFamilyAppType ty
-
-    -- For efficiency, represent both lists as difference lists.
-    -- comb performs the concatenation, for both lists.
-    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)
-
-    stepper = newTypeStepper `composeSteppers` tyFamStepper
-
-    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
-    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
-    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])
-    newTypeStepper rec_nts tc tys
-      | Just (ty', _co) <- instNewTyCon_maybe tc tys
-      = case checkRecTc rec_nts tc of
-          Just rec_nts' -> let tyf = ((TyConApp tc tys):)
-                               tmf = ((tyConSingleDataCon tc):)
-                           in  NS_Step rec_nts' ty' (tyf, tmf)
-          Nothing       -> NS_Abort
-      | otherwise
-      = NS_Done
-
-    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])
-    tyFamStepper rec_nts tc tys  -- Try to step a type/data family
-      = let (_args_co, ntys) = normaliseTcArgs env Representational tc tys in
-          -- NB: It's OK to use normaliseTcArgs here instead of
-          -- normalise_tc_args (which takes the LiftingContext described
-          -- in Note [Normalising types]) because the reduceTyFamApp below
-          -- works only at top level. We'll never recur in this function
-          -- after reducing the kind of a bound tyvar.
-
-        case reduceTyFamApp_maybe env Representational tc ntys of
-          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)
-          _               -> NS_Done
-
-{- Note [Type normalisation for EmptyCase]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-EmptyCase is an exception for pattern matching, since it is strict. This means
-that it boils down to checking whether the type of the scrutinee is inhabited.
-Function pmTopNormaliseType_maybe gets rid of the outermost type function/data
-family redex and newtypes, in search of an algebraic type constructor, which is
-easier to check for inhabitation.
-
-It returns 3 results instead of one, because there are 2 subtle points:
-1. Newtypes are isomorphic to the underlying type in core but not in the source
-   language,
-2. The representational data family tycon is used internally but should not be
-   shown to the user
-
-Hence, if pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty), then
-  (a) src_ty is the rewritten type which we can show to the user. That is, the
-      type we get if we rewrite type families but not data families or
-      newtypes.
-  (b) dcs is the list of data constructors "skipped", every time we normalise a
-      newtype to it's core representation, we keep track of the source data
-      constructor.
-  (c) core_ty is the rewritten type. That is,
-        pmTopNormaliseType_maybe env ty = Just (src_ty, dcs, core_ty)
-      implies
-        topNormaliseType_maybe env ty = Just (co, core_ty)
-      for some coercion co.
-
-To see how all cases come into play, consider the following example:
-
-  data family T a :: *
-  data instance T Int = T1 | T2 Bool
-  -- Which gives rise to FC:
-  --   data T a
-  --   data R:TInt = T1 | T2 Bool
-  --   axiom ax_ti : T Int ~R R:TInt
-
-  newtype G1 = MkG1 (T Int)
-  newtype G2 = MkG2 G1
-
-  type instance F Int  = F Char
-  type instance F Char = G2
-
-In this case pmTopNormaliseType_maybe env (F Int) results in
-
-  Just (G2, [MkG2,MkG1], R:TInt)
-
-Which means that in source Haskell:
-  - G2 is equivalent to F Int (in contrast, G1 isn't).
-  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).
--}
-
----------------
 normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)
 -- See comments on normaliseType for the arguments of this function
 normaliseTcApp env role tc tys
@@ -1356,13 +1294,7 @@ normalise_tc_app tc tys
     -- See Note [Normalisation and type synonyms]
     normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
 
-  | not (isTypeFamilyTyCon tc)
-  = -- A synonym with no type families in the RHS; or data type etc
-    -- Just normalise the arguments and rebuild
-    do { (args_co, ntys) <- normalise_tc_args tc tys
-       ; return (args_co, mkTyConApp tc ntys) }
-
-  | otherwise
+  | isFamilyTyCon tc
   = -- A type-family application
     do { env <- getEnv
        ; role <- getRole
@@ -1376,6 +1308,12 @@ normalise_tc_app tc tys
                 -- we do not do anything
                 return (args_co, mkTyConApp tc ntys) }
 
+  | otherwise
+  = -- A synonym with no type families in the RHS; or data type etc
+    -- Just normalise the arguments and rebuild
+    do { (args_co, ntys) <- normalise_tc_args tc tys
+       ; return (args_co, mkTyConApp tc ntys) }
+
 ---------------
 -- | Normalise arguments to a tycon
 normaliseTcArgs :: FamInstEnvs          -- ^ env't with family instances
@@ -1406,15 +1344,15 @@ normaliseType env role ty
   = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty
 
 normalise_type :: Type                     -- old type
-               -> NormM (Coercion, Type)   -- (coercion,new type), where
-                                         -- co :: old-type ~ new_type
+               -> NormM (Coercion, Type)   -- (coercion, new type), where
+                                           -- co :: old-type ~ new_type
 -- Normalise the input type, by eliminating *all* type-function redexes
 -- but *not* newtypes (which are visible to the programmer)
 -- Returns with Refl if nothing happens
 -- Does nothing to newtypes
 -- The returned coercion *must* be *homogeneous*
 -- See Note [Normalising types]
--- Try to not to disturb type synonyms if possible
+-- Try not to disturb type synonyms if possible
 
 normalise_type ty
   = go ty
@@ -1431,17 +1369,18 @@ normalise_type ty
            ; (co2, nty2) <- go ty2
            ; r <- getRole
            ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) }
-    go (ForAllTy (TvBndr tyvar vis) ty)
-      = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar
+    go (ForAllTy (Bndr tcvar vis) ty)
+      = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar
            ; (co, nty)          <- withLC lc' $ normalise_type ty
            ; let tv2 = setTyVarKind tv' ki'
-           ; return (mkForAllCo tv' h co, ForAllTy (TvBndr tv2 vis) nty) }
+           ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) }
     go (TyVarTy tv)    = normalise_tyvar tv
     go (CastTy ty co)
       = do { (nco, nty) <- go ty
            ; lc <- getLC
            ; let co' = substRightCo lc co
-           ; return (castCoercionKind nco co co', mkCastTy nty co') }
+           ; return (castCoercionKind nco Nominal ty nty co co'
+                    , mkCastTy nty co') }
     go (CoercionTy co)
       = do { lc <- getLC
            ; r <- getRole
@@ -1461,12 +1400,13 @@ normalise_tyvar tv
            Nothing -> (mkReflCo r ty, ty) }
   where ty = mkTyVarTy tv
 
-normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind)
-normalise_tyvar_bndr tv
+normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind)
+normalise_var_bndr tcvar
+  -- works for both tvar and covar
   = do { lc1 <- getLC
        ; env <- getEnv
        ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal
-       ; return $ liftCoSubstVarBndrCallback callback lc1 tv }
+       ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar }
 
 -- | a monad for the normalisation functions, reading 'FamInstEnvs',
 -- a 'LiftingContext', and a 'Role'.
@@ -1565,7 +1505,7 @@ flattenTys in_scope tys = snd $ coreFlattenTys env tys
     -- *anywhere* in the types we're flattening, even if locally-bound in
     -- a forall. That way, we can ensure consistency both within and outside
     -- of that forall.
-    all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys
+    all_in_scope = in_scope `extendInScopeSetSet` allTyCoVarsInTys tys
     env          = emptyFlattenEnv all_in_scope
 
 coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type])
@@ -1600,10 +1540,10 @@ coreFlattenTy = go
                                  (env2, ty2') = go env1 ty2 in
                              (env2, mkFunTy ty1' ty2')
 
-    go env (ForAllTy (TvBndr tv vis) ty)
+    go env (ForAllTy (Bndr tv vis) ty)
       = let (env1, tv') = coreFlattenVarBndr env tv
             (env2, ty') = go env1 ty in
-        (env2, ForAllTy (TvBndr tv' vis) ty')
+        (env2, ForAllTy (Bndr tv' vis) ty')
 
     go env ty@(LitTy {}) = (env, ty)
 
@@ -1627,20 +1567,20 @@ coreFlattenCo env co
     covar         = uniqAway in_scope (mkCoVar fresh_name kind')
     env2          = env1 { fe_subst = subst1 `extendTCvInScope` covar }
 
-coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar)
+coreFlattenVarBndr :: FlattenEnv -> TyCoVar -> (FlattenEnv, TyCoVar)
 coreFlattenVarBndr env tv
   | kind' `eqType` kind
-  = ( env { fe_subst = extendTvSubst old_subst tv (mkTyVarTy tv) }
+  = ( env { fe_subst = extendTCvSubst old_subst tv (mkTyCoVarTy tv) }
              -- override any previous binding for tv
     , tv)
 
   | otherwise
-  = let new_tv    = uniqAway (getTCvInScope old_subst) (setTyVarKind tv kind')
-        new_subst = extendTvSubstWithClone old_subst tv new_tv
+  = let new_tv    = uniqAway (getTCvInScope old_subst) (setVarType tv kind')
+        new_subst = extendTCvSubstWithClone old_subst tv new_tv
     in
     (env' { fe_subst = new_subst }, new_tv)
   where
-    kind          = tyVarKind tv
+    kind          = varType tv
     (env', kind') = coreFlattenTy env kind
     old_subst     = fe_subst env
 
@@ -1666,43 +1606,47 @@ coreFlattenTyFamApp env fam_tc fam_args
         FlattenEnv { fe_type_map = type_map
                    , fe_subst = subst } = env
 
--- | Get the set of all type variables mentioned anywhere in the list
+-- | Get the set of all type/coercion variables mentioned anywhere in the list
 -- of types. These variables are not necessarily free.
-allTyVarsInTys :: [Type] -> VarSet
-allTyVarsInTys []       = emptyVarSet
-allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys
+allTyCoVarsInTys :: [Type] -> VarSet
+allTyCoVarsInTys []       = emptyVarSet
+allTyCoVarsInTys (ty:tys) = allTyCoVarsInTy ty `unionVarSet` allTyCoVarsInTys tys
 
--- | Get the set of all type variables mentioned anywhere in a type.
-allTyVarsInTy :: Type -> VarSet
-allTyVarsInTy = go
+-- | Get the set of all type/coercion variables mentioned anywhere in a type.
+allTyCoVarsInTy :: Type -> VarSet
+allTyCoVarsInTy = go
   where
     go (TyVarTy tv)      = unitVarSet tv
-    go (TyConApp _ tys)  = allTyVarsInTys tys
+    go (TyConApp _ tys)  = allTyCoVarsInTys tys
     go (AppTy ty1 ty2)   = (go ty1) `unionVarSet` (go ty2)
     go (FunTy ty1 ty2)   = (go ty1) `unionVarSet` (go ty2)
-    go (ForAllTy (TvBndr tv _) ty) = unitVarSet tv     `unionVarSet`
-                                     go (tyVarKind tv) `unionVarSet`
-                                     go ty
-                                     -- Don't remove the tv from the set!
+    go (ForAllTy (Bndr tv _) ty) = unitVarSet tv     `unionVarSet`
+                                   go (tyVarKind tv) `unionVarSet`
+                                   go ty
+                                   -- Don't remove the tv from the set!
     go (LitTy {})        = emptyVarSet
     go (CastTy ty co)    = go ty `unionVarSet` go_co co
     go (CoercionTy co)   = go_co co
 
-    go_co (Refl _ ty)           = go ty
+    go_mco MRefl    = emptyVarSet
+    go_mco (MCo co) = go_co co
+
+    go_co (Refl ty)             = go ty
+    go_co (GRefl _ ty mco)      = go ty `unionVarSet` go_mco mco
     go_co (TyConAppCo _ _ args) = go_cos args
     go_co (AppCo co arg)        = go_co co `unionVarSet` go_co arg
     go_co (ForAllCo tv h co)
       = unionVarSets [unitVarSet tv, go_co co, go_co h]
     go_co (FunCo _ c1 c2)       = go_co c1 `unionVarSet` go_co c2
     go_co (CoVarCo cv)          = unitVarSet cv
+    go_co (HoleCo h)            = unitVarSet (coHoleCoVar h)
     go_co (AxiomInstCo _ _ cos) = go_cos cos
     go_co (UnivCo p _ t1 t2)    = go_prov p `unionVarSet` go t1 `unionVarSet` go t2
     go_co (SymCo co)            = go_co co
     go_co (TransCo c1 c2)       = go_co c1 `unionVarSet` go_co c2
-    go_co (NthCo _ co)          = go_co co
+    go_co (NthCo _ _ co)        = go_co co
     go_co (LRCo _ co)           = go_co co
     go_co (InstCo co arg)       = go_co co `unionVarSet` go_co arg
-    go_co (CoherenceCo c1 c2)   = go_co c1 `unionVarSet` go_co c2
     go_co (KindCo co)           = go_co co
     go_co (SubCo co)            = go_co co
     go_co (AxiomRuleCo _ cs)    = go_cos cs
@@ -1713,7 +1657,6 @@ allTyVarsInTy = go
     go_prov (PhantomProv co)    = go_co co
     go_prov (ProofIrrelProv co) = go_co co
     go_prov (PluginProv _)      = emptyVarSet
-    go_prov (HoleProv _)        = emptyVarSet
 
 mkFlattenFreshTyName :: Uniquable a => a -> Name
 mkFlattenFreshTyName unq
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index 8198a5360f..c45aa7cccd 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -18,9 +18,12 @@ module InstEnv (
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
         InstEnvs(..), VisibleOrphanModules, InstEnv,
-        emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalClsInstHead,
+        emptyInstEnv, extendInstEnv,
+        deleteFromInstEnv, deleteDFunFromInstEnv,
+        identicalClsInstHead,
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts,
-        memberInstEnv, instIsVisible,
+        memberInstEnv,
+        instIsVisible,
         classInstances, instanceBindFun,
         instanceCantMatch, roughMatchTcs,
         isOverlappable, isOverlapping, isIncoherent
@@ -28,6 +31,8 @@ module InstEnv (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcType -- InstEnv is really part of the type checker,
               -- and depends on TcType in many ways
 import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor )
@@ -213,7 +218,7 @@ pprInstance :: ClsInst -> SDoc
 pprInstance ispec
   = hang (pprInstanceHdr ispec)
        2 (vcat [ text "--" <+> pprDefinedAt (getName ispec)
-               , ifPprDebug (ppr (is_dfun ispec)) ])
+               , whenPprDebug (ppr (is_dfun ispec)) ])
 
 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
 pprInstanceHdr :: ClsInst -> SDoc
@@ -430,11 +435,11 @@ instIsVisible vis_mods ispec
   -- NB: Instances from the interactive package always are visible. We can't
   -- add interactive modules to the set since we keep creating new ones
   -- as a GHCi session progresses.
-  | isInteractiveModule mod     = True
-  | IsOrphan <- is_orphan ispec = mod `elemModuleSet` vis_mods
-  | otherwise                   = True
-  where
-    mod = nameModule $ is_dfun_name ispec
+  = case nameModule_maybe (is_dfun_name ispec) of
+      Nothing -> True
+      Just mod | isInteractiveModule mod     -> True
+               | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods
+               | otherwise                   -> True
 
 classInstances :: InstEnvs -> Class -> [ClsInst]
 classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls
@@ -455,7 +460,7 @@ memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) =
     eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))
 
 extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
-extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
+extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs
 
 extendInstEnv :: InstEnv -> ClsInst -> InstEnv
 extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
@@ -469,6 +474,15 @@ deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm })
   where
     adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items)
 
+deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv
+-- Delete a specific instance fron an InstEnv
+deleteDFunFromInstEnv inst_env dfun
+  = adjustUDFM adjust inst_env cls
+  where
+    (_, _, cls, _) = tcSplitDFunTy (idType dfun)
+    adjust (ClsIE items) = ClsIE (filterOut same_dfun items)
+    same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun'
+
 identicalClsInstHead :: ClsInst -> ClsInst -> Bool
 -- ^ True when when the instance heads are the same
 -- e.g.  both are   Eq [(a,b)]
@@ -547,23 +561,38 @@ instance declaration itself, controlled as follows:
 Now suppose that, in some client module, we are searching for an instance
 of the target constraint (C ty1 .. tyn). The search works like this.
 
- * Find all instances I that match the target constraint; that is, the
-   target constraint is a substitution instance of I. These instance
-   declarations are the candidates.
+*  Find all instances `I` that *match* the target constraint; that is, the
+   target constraint is a substitution instance of `I`. These instance
+   declarations are the *candidates*.
 
- * Find all non-candidate instances that unify with the target
-   constraint. Such non-candidates instances might match when the
-   target constraint is further instantiated. If all of them are
-   incoherent, proceed; if not, the search fails.
+*  Eliminate any candidate `IX` for which both of the following hold:
 
- * Eliminate any candidate IX for which both of the following hold:
-   * There is another candidate IY that is strictly more specific;
-     that is, IY is a substitution instance of IX but not vice versa.
+   -  There is another candidate `IY` that is strictly more specific; that
+      is, `IY` is a substitution instance of `IX` but not vice versa.
 
-   * Either IX is overlappable or IY is overlapping.
+   -  Either `IX` is *overlappable*, or `IY` is *overlapping*. (This
+      "either/or" design, rather than a "both/and" design, allow a
+      client to deliberately override an instance from a library,
+      without requiring a change to the library.)
 
- * If only one candidate remains, pick it. Otherwise if all remaining
-   candidates are incoherent, pick an arbitrary candidate. Otherwise fail.
+-  If exactly one non-incoherent candidate remains, select it. If all
+   remaining candidates are incoherent, select an arbitrary one.
+   Otherwise the search fails (i.e. when more than one surviving
+   candidate is not incoherent).
+
+-  If the selected candidate (from the previous step) is incoherent, the
+   search succeeds, returning that candidate.
+
+-  If not, find all instances that *unify* with the target constraint,
+   but do not *match* it. Such non-candidate instances might match when
+   the target constraint is further instantiated. If all of them are
+   incoherent, the search succeeds, returning the selected candidate; if
+   not, the search fails.
+
+Notice that these rules are not influenced by flag settings in the
+client module, where the instances are *used*. These rules make it
+possible for a library author to design a library that relies on
+overlapping instances without the client having to know.
 
 Note [Overlapping instances]   (NB: these notes are quite old)
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -674,7 +703,7 @@ prematurely chosing a generic instance when a more specific one
 exists.
 
 --Jeff
-v
+
 BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in
 this test.  Suppose the instance envt had
     ..., forall a b. C a a b, ..., forall a b c. C a b c, ...
@@ -739,7 +768,8 @@ lookupInstEnv' :: InstEnv          -- InstEnv to look in
                -> VisibleOrphanModules   -- But filter against this
                -> Class -> [Type]  -- What we are looking for
                -> ([InstMatch],    -- Successful matches
-                   [ClsInst])     -- These don't match but do unify
+                   [ClsInst])      -- These don't match but do unify
+                                   -- (no incoherent ones in here)
 -- The second component of the result pair happens when we look up
 --      Foo [a]
 -- in an InstEnv that has entries for
@@ -776,7 +806,8 @@ lookupInstEnv' ie vis_mods cls tys
       = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest
 
         -- Does not match, so next check whether the things unify
-        -- See Note [Overlapping instances] and Note [Incoherent instances]
+        -- See Note [Overlapping instances]
+        -- Ignore ones that are incoherent: Note [Incoherent instances]
       | isIncoherent item
       = find ms us rest
 
diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs
index ae11c8a651..f88bbe1c0d 100644
--- a/compiler/types/Kind.hs
+++ b/compiler/types/Kind.hs
@@ -3,24 +3,22 @@
 {-# LANGUAGE CPP #-}
 module Kind (
         -- * Main data type
-        Kind, typeKind,
+        Kind,
 
         -- ** Predicates on Kinds
         isLiftedTypeKind, isUnliftedTypeKind,
-        isConstraintKind,
         isTYPEApp,
-        returnsTyCon, returnsConstraintKind,
         isConstraintKindCon,
 
         classifiesTypeWithValues,
-        isStarKind, isStarKindSynonymTyCon,
-        tcIsStarKind,
         isKindLevPoly
        ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Type    ( typeKind, coreView, tcView
+import GhcPrelude
+
+import {-# SOURCE #-} Type    ( coreView
                               , splitTyConApp_maybe )
 import {-# SOURCE #-} DataCon ( DataCon )
 
@@ -38,7 +36,7 @@ import Util
 *                                                                      *
 ************************************************************************
 
-Note [Kind Constraint and kind *]
+Note [Kind Constraint and kind Type]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The kind Constraint is the kind of classes and other type constraints.
 The special thing about types of kind Constraint is that
@@ -49,27 +47,22 @@ The special thing about types of kind Constraint is that
    to f.
 
 However, once type inference is over, there is *no* distinction between
-Constraint and *.  Indeed we can have coercions between the two. Consider
+Constraint and Type. Indeed we can have coercions between the two. Consider
    class C a where
      op :: a -> a
 For this single-method class we may generate a newtype, which in turn
 generates an axiom witnessing
     C a ~ (a -> a)
-so on the left we have Constraint, and on the right we have *.
+so on the left we have Constraint, and on the right we have Type.
 See Trac #7451.
 
-Bottom line: although '*' and 'Constraint' are distinct TyCons, with
+Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with
 distinct uniques, they are treated as equal at all times except
 during type inference.
 -}
 
-isConstraintKind :: Kind -> Bool
 isConstraintKindCon :: TyCon -> Bool
-
-isConstraintKindCon   tc = tyConUnique tc == constraintKindTyConKey
-
-isConstraintKind (TyConApp tc _) = isConstraintKindCon tc
-isConstraintKind _               = False
+isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey
 
 isTYPEApp :: Kind -> Maybe DataCon
 isTYPEApp (TyConApp tc args)
@@ -80,22 +73,13 @@ isTYPEApp (TyConApp tc args)
   = Just dc
 isTYPEApp _ = Nothing
 
--- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@
--- ends in @*@ and @Maybe a -> [a]@ ends in @[]@.
-returnsTyCon :: Unique -> Type -> Bool
-returnsTyCon tc_u (ForAllTy _ ty)  = returnsTyCon tc_u ty
-returnsTyCon tc_u (FunTy    _ ty)  = returnsTyCon tc_u ty
-returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u
-returnsTyCon _  _                  = False
-
-returnsConstraintKind :: Kind -> Bool
-returnsConstraintKind = returnsTyCon constraintKindTyConKey
-
 -- | Tests whether the given kind (which should look like @TYPE x@)
 -- is something other than a constructor tree (that is, constructors at every node).
+-- E.g.  True of   TYPE k, TYPE (F Int)
+--       False of  TYPE 'LiftedRep
 isKindLevPoly :: Kind -> Bool
-isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k )
-                      -- the isStarKind check is necessary b/c of Constraint
+isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k )
+                    -- the isLiftedTypeKind check is necessary b/c of Constraint
                   go k
   where
     go ty | Just ty' <- coreView ty = go ty'
@@ -126,27 +110,4 @@ isKindLevPoly k = ASSERT2( isStarKind k || _is_type, ppr k )
 -- like *, #, TYPE Lifted, TYPE v, Constraint.
 classifiesTypeWithValues :: Kind -> Bool
 -- ^ True of any sub-kind of OpenTypeKind
-classifiesTypeWithValues t | Just t' <- coreView t = classifiesTypeWithValues t'
-classifiesTypeWithValues (TyConApp tc [_]) = tc `hasKey` tYPETyConKey
-classifiesTypeWithValues _ = False
-
--- | Is this kind equivalent to *?
-tcIsStarKind :: Kind -> Bool
-tcIsStarKind k | Just k' <- tcView k = isStarKind k'
-tcIsStarKind (TyConApp tc [TyConApp ptr_rep []])
-  =  tc      `hasKey` tYPETyConKey
-  && ptr_rep `hasKey` liftedRepDataConKey
-tcIsStarKind _ = False
-
--- | Is this kind equivalent to *?
-isStarKind :: Kind -> Bool
-isStarKind k | Just k' <- coreView k = isStarKind k'
-isStarKind (TyConApp tc [TyConApp ptr_rep []])
-  =  tc      `hasKey` tYPETyConKey
-  && ptr_rep `hasKey` liftedRepDataConKey
-isStarKind _ = False
-                              -- See Note [Kind Constraint and kind *]
-
--- | Is the tycon @Constraint@?
-isStarKindSynonymTyCon :: TyCon -> Bool
-isStarKindSynonymTyCon tc = tc `hasKey` constraintKindTyConKey
+classifiesTypeWithValues = isTYPE (const True)
diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs
index 67644094ed..8a44b86f7e 100644
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/types/OptCoercion.hs
@@ -4,14 +4,14 @@
 
 -- The default iteration limit is a bit too low for the definitions
 -- in this module.
-#if __GLASGOW_HASKELL__ >= 800
 {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-#endif
 
 module OptCoercion ( optCoercion, checkAxInstCo ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import DynFlags
 import TyCoRep
 import Coercion
@@ -55,6 +55,7 @@ opt_co2.
 
 Note [Optimising InstCo]
 ~~~~~~~~~~~~~~~~~~~~~~~~
+(1) tv is a type variable
 When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.
 
 Let's look at the typing rules.
@@ -74,27 +75,55 @@ We thus want some coercion proving this:
   (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])
 
 If we substitute the *type* tv for the *coercion*
-(g2 `mkCoherenceRightCo` sym h) in g, we'll get this result exactly.
+(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly.
 This is bizarre,
 though, because we're substituting a type variable with a coercion. However,
 this operation already exists: it's called *lifting*, and defined in Coercion.
 We just need to enhance the lifting operation to be able to deal with
 an ambient substitution, which is why a LiftingContext stores a TCvSubst.
 
+(2) cv is a coercion variable
+Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.
+
+h : (t1 ~r t2) ~N (t3 ~r t4)
+cv : t1 ~r t2 |- g : t1' ~r2 t2'
+n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3
+n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4
+------------------------------------------------
+ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2
+                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])
+
+g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')
+g2 : h1 ~N h2
+h1 : t1 ~r t2
+h2 : t3 ~r t4
+------------------------------------------------
+InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]
+
+We thus want some coercion proving this:
+
+  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]
+
+So we substitute the coercion variable c for the coercion
+(h1 ~N (n1; h2; sym n2)) in g.
 -}
 
-optCoercion :: TCvSubst -> Coercion -> NormalCo
+optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo
 -- ^ optCoercion applies a substitution to a coercion,
 --   *and* optimises it to reduce its size
-optCoercion env co
-  | hasNoOptCoercion unsafeGlobalDynFlags = substCo env co
+optCoercion dflags env co
+  | hasNoOptCoercion dflags = substCo env co
+  | otherwise               = optCoercion' env co
+
+optCoercion' :: TCvSubst -> Coercion -> NormalCo
+optCoercion' env co
   | debugIsOn
   = let out_co = opt_co1 lc False co
         (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co
         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
     in
-    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&
-             substTyUnchecked env in_ty2 `eqType` out_ty2 &&
+    ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
+             substTy env in_ty2 `eqType` out_ty2 &&
              in_role == out_role
            , text "optCoercion changed types!"
              $$ hang (text "in_co:") 2 (ppr co)
@@ -166,12 +195,30 @@ opt_co4_wrap env sym rep r co
     result
 -}
 
-opt_co4 env _   rep r (Refl _r ty)
+opt_co4 env _   rep r (Refl ty)
+  = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r    $$
+                           text "Found role:" <+> ppr Nominal $$
+                           text "Type:" <+> ppr ty )
+    liftCoSubst (chooseRole rep r) env ty
+
+opt_co4 env _   rep r (GRefl _r ty MRefl)
   = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$
                       text "Found role:" <+> ppr _r   $$
                       text "Type:" <+> ppr ty )
     liftCoSubst (chooseRole rep r) env ty
 
+opt_co4 env sym  rep r (GRefl _r ty (MCo co))
+  = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$
+                      text "Found role:" <+> ppr _r   $$
+                      text "Type:" <+> ppr ty )
+    if isGReflCo co || isGReflCo co'
+    then liftCoSubst r' env ty
+    else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)
+  where
+    r'  = chooseRole rep r
+    ty' = substTy (lcSubstLeft env) ty
+    co' = opt_co4 env False False Nominal co
+
 opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co
   -- surprisingly, we don't have to do anything to the env here. This is
   -- because any "lifting" substitutions in the env are tied to ForAllCos,
@@ -221,7 +268,7 @@ opt_co4 env sym rep r (CoVarCo cv)
   = opt_co4_wrap (zapLiftingContext env) sym rep r co
 
   | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]
-  = Refl (chooseRole rep r) ty1
+  = mkReflCo (chooseRole rep r) ty1
 
   | otherwise
   = ASSERT( isCoVar cv1 )
@@ -238,6 +285,8 @@ opt_co4 env sym rep r (CoVarCo cv)
                          cv
           -- cv1 might have a substituted kind!
 
+opt_co4 _ _ _ _ (HoleCo h)
+  = pprPanic "opt_univ fell into a hole" (ppr h)
 
 opt_co4 env sym rep r (AxiomInstCo con ind cos)
     -- Do *not* push sym inside top-level axioms
@@ -267,8 +316,44 @@ opt_co4 env sym rep r (TransCo co1 co2)
     co2' = opt_co4_wrap env sym rep r co2
     in_scope = lcInScopeSet env
 
+opt_co4 env _sym rep r (NthCo _r n co)
+  | Just (ty, _) <- isReflCo_maybe co
+  , Just (_tc, args) <- ASSERT( r == _r )
+                        splitTyConApp_maybe ty
+  = liftCoSubst (chooseRole rep r) env (args `getNth` n)
+  | Just (ty, _) <- isReflCo_maybe co
+  , n == 0
+  , Just (tv, _) <- splitForAllTy_maybe ty
+      -- works for both tyvar and covar
+  = liftCoSubst (chooseRole rep r) env (varType tv)
+
+opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))
+  = ASSERT( r == r1 )
+    opt_co4_wrap env sym rep r (cos `getNth` n)
+
+opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))
+      -- works for both tyvar and covar
+  = ASSERT( r == _r )
+    ASSERT( n == 0 )
+    opt_co4_wrap env sym rep Nominal eta
+
+opt_co4 env sym rep r (NthCo _r n co)
+  | TyConAppCo _ _ cos <- co'
+  , let nth_co = cos `getNth` n
+  = if rep && (r == Nominal)
+      -- keep propagating the SubCo
+    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co
+    else nth_co
+
+  | ForAllCo _ eta _ <- co'
+  = if rep
+    then opt_co4_wrap (zapLiftingContext env) False True Nominal eta
+    else eta
 
-opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co
+  | otherwise
+  = wrapRole rep r $ NthCo r n co'
+  where
+    co' = opt_co1 env sym co
 
 opt_co4 env sym rep r (LRCo lr co)
   | Just pr_co <- splitAppCo_maybe co
@@ -290,41 +375,58 @@ opt_co4 env sym rep r (LRCo lr co)
 -- See Note [Optimising InstCo]
 opt_co4 env sym rep r (InstCo co1 arg)
     -- forall over type...
-  | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1
+  | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1
   = opt_co4_wrap (extendLiftingContext env tv
-                    (arg' `mkCoherenceRightCo` mkSymCo kind_co))
+                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) arg'))
+                   -- kind_co :: k1 ~ k2
+                   -- arg' :: (t1 :: k1) ~ (t2 :: k2)
+                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)
                  sym rep r co_body
 
+    -- forall over coercion...
+  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1
+  , CoercionTy h1 <- t1
+  , CoercionTy h2 <- t2
+  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2
+    in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body
+
     -- See if it is a forall after optimization
     -- If so, do an inefficient one-variable substitution, then re-optimize
 
     -- forall over type...
-  | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1'
+  | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1'
   = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'
-                    (arg' `mkCoherenceRightCo` mkSymCo kind_co'))
+                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co') arg'))
             False False r' co_body'
 
+    -- forall over coercion...
+  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'
+  , CoercionTy h1 <- t1
+  , CoercionTy h2 <- t2
+  = let new_co = mk_new_co cv' kind_co' h1 h2
+    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)
+                    False False r' co_body'
+
   | otherwise = InstCo co1' arg'
   where
     co1' = opt_co4_wrap env sym rep r co1
     r'   = chooseRole rep r
     arg' = opt_co4_wrap env sym False Nominal arg
-
-opt_co4 env sym rep r (CoherenceCo co1 co2)
-  | TransCo col1 cor1 <- co1
-  = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1)
-
-  | TransCo col1' cor1' <- co1'
-  = if sym then opt_trans in_scope col1'
-                  (optCoercion (zapTCvSubst (lcTCvSubst env))
-                               (mkCoherenceRightCo cor1' co2'))
-           else opt_trans in_scope (mkCoherenceCo col1' co2') cor1'
-
-  | otherwise
-  = wrapSym sym $ mkCoherenceCo (opt_co4_wrap env False rep r co1) co2'
-  where co1' = opt_co4_wrap env sym   rep   r       co1
-        co2' = opt_co4_wrap env False False Nominal co2
-        in_scope = lcInScopeSet env
+    Pair t1 t2 = coercionKind arg'
+
+    mk_new_co cv kind_co h1 h2
+      = let -- h1 :: (t1 ~ t2)
+            -- h2 :: (t3 ~ t4)
+            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)
+            -- n1 :: t1 ~ t3
+            -- n2 :: t2 ~ t4
+            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)
+            r2  = coVarRole cv
+            kind_co' = downgradeRole r2 Nominal kind_co
+            n1 = mkNthCo r2 2 kind_co'
+            n2 = mkNthCo r2 3 kind_co'
+         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1
+                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))
 
 opt_co4 env sym _rep r (KindCo co)
   = ASSERT( r == Nominal )
@@ -396,25 +498,43 @@ opt_univ env sym prov role oty1 oty2
       -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);
       -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps
   = let roles    = tyConRolesX role tc1
-        arg_cos  = zipWith3 (mkUnivCo prov) roles tys1 tys2
+        arg_cos  = zipWith3 (mkUnivCo prov') roles tys1 tys2
         arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos
     in
     mkTyConAppCo role tc1 arg_cos'
 
   -- can't optimize the AppTy case because we can't build the kind coercions.
 
-  | Just (tv1, ty1) <- splitForAllTy_maybe oty1
-  , Just (tv2, ty2) <- splitForAllTy_maybe oty2
+  | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1
+  , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2
       -- NB: prov isn't interesting here either
   = let k1   = tyVarKind tv1
         k2   = tyVarKind tv2
-        eta  = mkUnivCo prov Nominal k1 k2
+        eta  = mkUnivCo prov' Nominal k1 k2
           -- eta gets opt'ed soon, but not yet.
         ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2
 
         (env', tv1', eta') = optForAllCoBndr env sym tv1 eta
     in
-    mkForAllCo tv1' eta' (opt_univ env' sym prov role ty1 ty2')
+    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')
+
+  | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1
+  , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2
+      -- NB: prov isn't interesting here either
+  = let k1    = varType cv1
+        k2    = varType cv2
+        r'    = coVarRole cv1
+        eta   = mkUnivCo prov' Nominal k1 k2
+        eta_d = downgradeRole r' Nominal eta
+          -- eta gets opt'ed soon, but not yet.
+        n_co  = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo`
+                (mkCoVarCo cv1) `mkTransCo`
+                (mkNthCo r' 3 eta_d)
+        ty2'  = substTyWithCoVars [cv2] [n_co] ty2
+
+        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta
+    in
+    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')
 
   | otherwise
   = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1
@@ -430,64 +550,6 @@ opt_univ env sym prov role oty1 oty2
       PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco
       ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
       PluginProv _       -> prov
-      HoleProv h         -> pprPanic "opt_univ fell into a hole" (ppr h)
-
-
--------------
--- NthCo must be handled separately, because it's the one case where we can't
--- tell quickly what the component coercion's role is from the containing
--- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2,
--- we just look for nested NthCo's, which can happen in practice.
-opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo
-opt_nth_co env sym rep r = go []
-  where
-    go ns (NthCo n co) = go (n:ns) co
-      -- previous versions checked if the tycon is decomposable. This
-      -- is redundant, because a non-decomposable tycon under an NthCo
-      -- is entirely bogus. See docs/core-spec/core-spec.pdf.
-    go ns co
-      = opt_nths ns co
-
-      -- try to resolve 1 Nth
-    push_nth n (Refl r1 ty)
-      | Just (tc, args) <- splitTyConApp_maybe ty
-      = Just (Refl (nthRole r1 tc n) (args `getNth` n))
-      | n == 0
-      , Just (tv, _) <- splitForAllTy_maybe ty
-      = Just (Refl Nominal (tyVarKind tv))
-    push_nth n (TyConAppCo _ _ cos)
-      = Just (cos `getNth` n)
-    push_nth 0 (ForAllCo _ eta _)
-      = Just eta
-    push_nth _ _ = Nothing
-
-      -- input coercion is *not* yet sym'd or opt'd
-    opt_nths [] co = opt_co4_wrap env sym rep r co
-    opt_nths (n:ns) co
-      | Just co' <- push_nth n co
-      = opt_nths ns co'
-
-      -- here, the co isn't a TyConAppCo, so we opt it, hoping to get
-      -- a TyConAppCo as output. We don't know the role, so we use
-      -- opt_co1. This is slightly annoying, because opt_co1 will call
-      -- coercionRole, but as long as we don't have a long chain of
-      -- NthCo's interspersed with some other coercion former, we should
-      -- be OK.
-    opt_nths ns co = opt_nths' ns (opt_co1 env sym co)
-
-      -- input coercion *is* sym'd and opt'd
-    opt_nths' [] co
-      = if rep && (r == Nominal)
-            -- propagate the SubCo:
-        then opt_co4_wrap (zapLiftingContext env) False True r co
-        else co
-    opt_nths' (n:ns) co
-      | Just co' <- push_nth n co
-      = opt_nths' ns co'
-    opt_nths' ns co = wrapRole rep r (mk_nths ns co)
-
-    mk_nths [] co = co
-    mk_nths (n:ns) co = mk_nths ns (mkNthCo n co)
 
 -------------
 opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
@@ -496,12 +558,14 @@ opt_transList is = zipWith (opt_trans is)
 opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
 opt_trans is co1 co2
   | isReflCo co1 = co2
+    -- optimize when co1 is a Refl Co
   | otherwise    = opt_trans1 is co1 co2
 
 opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo
 -- First arg is not the identity
 opt_trans1 is co1 co2
   | isReflCo co2 = co1
+    -- optimize when co2 is a Refl Co
   | otherwise    = opt_trans2 is co1 co2
 
 opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo
@@ -527,12 +591,19 @@ opt_trans2 _ co1 co2
 -- Optimize coercions with a top-level use of transitivity.
 opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
 
+opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))
+  = ASSERT( r1 == r2 )
+    fireTransRule "GRefl" in_co1 in_co2 $
+    mkGReflRightCo r1 t1 (opt_trans is co1 co2)
+
 -- Push transitivity through matching destructors
-opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)
   | d1 == d2
+  , coercionRole co1 == coercionRole co2
   , co1 `compatible_co` co2
-  = fireTransRule "PushNth" in_co1 in_co2 $
-    mkNthCo d1 (opt_trans is co1 co2)
+  = ASSERT( r1 == r2 )
+    fireTransRule "PushNth" in_co1 in_co2 $
+    mkNthCo r1 d1 (opt_trans is co1 co2)
 
 opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
   | d1 == d2
@@ -576,9 +647,8 @@ opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b)
     mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b)
 
 opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
-  = fireTransRule "TrPushApp" in_co1 in_co2 $
-    mkAppCo (opt_trans is co1a co2a)
-            (opt_trans is co1b co2b)
+  -- Must call opt_trans_rule_app; see Note [EtaAppCo]
+  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]
 
 -- Eta rules
 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
@@ -595,33 +665,67 @@ opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
 
 opt_trans_rule is co1@(AppCo co1a co1b) co2
   | Just (co2a,co2b) <- etaAppCo_maybe co2
-  = fireTransRule "EtaAppL" co1 co2 $
-    mkAppCo (opt_trans is co1a co2a)
-            (opt_trans is co1b co2b)
+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
 
 opt_trans_rule is co1 co2@(AppCo co2a co2b)
   | Just (co1a,co1b) <- etaAppCo_maybe co1
-  = fireTransRule "EtaAppR" co1 co2 $
-    mkAppCo (opt_trans is co1a co2a)
-            (opt_trans is co1b co2b)
+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
 
 -- Push transitivity inside forall
+-- forall over types.
 opt_trans_rule is co1 co2
-  | ForAllCo tv1 eta1 r1 <- co1
-  , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2
+  | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1
+  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2
   = push_trans tv1 eta1 r1 tv2 eta2 r2
 
-  | ForAllCo tv2 eta2 r2 <- co2
-  , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1
+  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2
+  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1
   = push_trans tv1 eta1 r1 tv2 eta2 r2
 
   where
   push_trans tv1 eta1 r1 tv2 eta2 r2
-    = fireTransRule "EtaAllTy" co1 co2 $
+    -- Given:
+    --   co1 = /\ tv1 : eta1. r1
+    --   co2 = /\ tv2 : eta2. r2
+    -- Wanted:
+    --   /\tv1 : (eta1;eta2).  (r1; r2[tv2 |-> tv1 |> eta1])
+    = fireTransRule "EtaAllTy_ty" co1 co2 $
       mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
     where
       is' = is `extendInScopeSet` tv1
-      r2' = substCoWithUnchecked [tv2] [TyVarTy tv1] r2
+      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2
+
+-- Push transitivity inside forall
+-- forall over coercions.
+opt_trans_rule is co1 co2
+  | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1
+  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2
+  = push_trans cv1 eta1 r1 cv2 eta2 r2
+
+  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2
+  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1
+  = push_trans cv1 eta1 r1 cv2 eta2 r2
+
+  where
+  push_trans cv1 eta1 r1 cv2 eta2 r2
+    -- Given:
+    --   co1 = /\ cv1 : eta1. r1
+    --   co2 = /\ cv2 : eta2. r2
+    -- Wanted:
+    --   n1 = nth 2 eta1
+    --   n2 = nth 3 eta1
+    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])
+    = fireTransRule "EtaAllTy_co" co1 co2 $
+      mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
+    where
+      is'  = is `extendInScopeSet` cv1
+      role = coVarRole cv1
+      eta1' = downgradeRole role Nominal eta1
+      n1   = mkNthCo role 2 eta1'
+      n2   = mkNthCo role 3 eta1'
+      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`
+                                        (mkCoVarCo cv1) `mkTransCo` n2])
+                    r2
 
 -- Push transitivity inside axioms
 opt_trans_rule is co1 co2
@@ -682,25 +786,56 @@ opt_trans_rule is co1 co2
     co2_is_axiom_maybe = isAxiom_maybe co2
     role = coercionRole co1 -- should be the same as coercionRole co2!
 
-opt_trans_rule is co1 co2
-  | Just (lco, lh) <- isCohRight_maybe co1
-  , Just (rco, rh) <- isCohLeft_maybe co2
-  , (coercionType lh) `eqType` (coercionType rh)
-  = opt_trans_rule is lco rco
-
 opt_trans_rule _ co1 co2        -- Identity rule
   | (Pair ty1 _, r) <- coercionKindRole co1
   , Pair _ ty2 <- coercionKind co2
   , ty1 `eqType` ty2
   = fireTransRule "RedTypeDirRefl" co1 co2 $
-    Refl r ty2
+    mkReflCo r ty2
 
 opt_trans_rule _ _ _ = Nothing
 
+-- See Note [EtaAppCo]
+opt_trans_rule_app :: InScopeSet
+                   -> Coercion   -- original left-hand coercion (printing only)
+                   -> Coercion   -- original right-hand coercion (printing only)
+                   -> Coercion   -- left-hand coercion "function"
+                   -> [Coercion] -- left-hand coercion "args"
+                   -> Coercion   -- right-hand coercion "function"
+                   -> [Coercion] -- right-hand coercion "args"
+                   -> Maybe Coercion
+opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
+  | AppCo co1aa co1ab <- co1a
+  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a
+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
+
+  | AppCo co2aa co2ab <- co2a
+  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a
+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
+
+  | otherwise
+  = ASSERT( co1bs `equalLength` co2bs )
+    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $
+    let Pair _ rt1a = coercionKind co1a
+        (Pair lt2a _, rt2a) = coercionKindRole co2a
+
+        Pair _ rt1bs = traverse coercionKind co1bs
+        Pair lt2bs _ = traverse coercionKind co2bs
+        rt2bs = map coercionRole co2bs
+
+        kcoa = mkKindCo $ buildCoercion lt2a rt1a
+        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs
+
+        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a
+        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs
+        co2bs'' = zipWith mkTransCo co2bs' co2bs
+    in
+    mkAppCos (opt_trans is co1a co2a')
+             (zipWith (opt_trans is) co1bs co2bs'')
+
 fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
 fireTransRule _rule _co1 _co2 res
-  = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $
-    Just res
+  = Just res
 
 {-
 Note [Conflict checking with AxiomInstCo]
@@ -757,6 +892,64 @@ that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type
 families. At the time of writing, I (Richard Eisenberg) couldn't think of
 a way of detecting this any more efficient than just building the optimised
 coercion and checking.
+
+Note [EtaAppCo]
+~~~~~~~~~~~~~~~
+Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd
+like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that
+the resultant coercions might not be well kinded. Here is an example (things
+labeled with x don't matter in this example):
+
+  k1 :: Type
+  k2 :: Type
+
+  a :: k1 -> Type
+  b :: k1
+
+  h :: k1 ~ k2
+
+  co1a :: x1 ~ (a |> (h -> <Type>)
+  co1b :: x2 ~ (b |> h)
+
+  co2a :: a ~ x3
+  co2b :: b ~ x4
+
+First, convince yourself of the following:
+
+  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)
+  co2a co2b :: a b   ~ x3 x4
+
+  (a |> (h -> <Type>)) (b |> h) `eqType` a b
+
+That last fact is due to Note [Non-trivial definitional equality] in TyCoRep,
+where we ignore coercions in types as long as two types' kinds are the same.
+In our case, we meet this last condition, because
+
+  (a |> (h -> <Type>)) (b |> h) :: Type
+    and
+  a b :: Type
+
+So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the
+suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the
+kinds don't match up.
+
+The solution here is to twiddle the kinds in the output coercions. First, we
+need to find coercions
+
+  ak :: kind(a |> (h -> <Type>)) ~ kind(a)
+  bk :: kind(b |> h)             ~ kind(b)
+
+This can be done with mkKindCo and buildCoercion. The latter assumes two
+types are identical modulo casts and builds a coercion between them.
+
+Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the
+output coercions. These are well-kinded.
+
+Also, note that all of this is done after accumulated any nested AppCo
+parameters. This step is to avoid quadratic behavior in calling coercionKind.
+
+The problem described here was first found in dependent/should_compile/dynamic-paper.
+
 -}
 
 -- | Check to make sure that an AxInstCo is internally consistent.
@@ -839,18 +1032,6 @@ matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co
   = Nothing
 
 -------------
--- destruct a CoherenceCo
-isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion)
-isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2)
-isCohLeft_maybe _                     = Nothing
-
--- destruct a (sym (co1 |> co2)).
--- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co
-isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion)
-isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2)
-isCohRight_maybe _                             = Nothing
-
--------------
 compatible_co :: Coercion -> Coercion -> Bool
 -- Check whether (co1 . co2) will be well-kinded
 compatible_co co1 co2
@@ -861,42 +1042,83 @@ compatible_co co1 co2
 
 -------------
 {-
-etaForAllCo_maybe
+etaForAllCo
 ~~~~~~~~~~~~~~~~~
+(1) etaForAllCo_ty_maybe
 Suppose we have
 
   g : all a1:k1.t1  ~  all a2:k2.t2
 
 but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:
 
-  g' = all a1:(ForAllKindCo g).(InstCo g (a1 `mkCoherenceRightCo` ForAllKindCo g))
+  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))
 
 Call the kind coercion h1 and the body coercion h2. We can see that
 
-  h2 : t1 ~ t2[a2 |-> (a1 |> h2)]
+  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]
 
 According to the typing rule for ForAllCo, we get that
 
-  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2])
+  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])
 
 or
 
   g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])
 
 as desired.
+
+(2) etaForAllCo_co_maybe
+Suppose we have
+
+  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2
+
+Similarly, we do this
+
+  g' = all c1:h1. h2
+     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]
+                                              [c1 |-> eta1;c1;sym eta2]
+
+Here,
+
+  h1   = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4)
+  eta1 = mkNthCo r 2 h1      :: (s1 ~ s3)
+  eta2 = mkNthCo r 3 h1      :: (s2 ~ s4)
+  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))
 -}
-etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
 -- Try to make the coercion be of form (forall tv:kind_co. co)
-etaForAllCo_maybe co
-  | ForAllCo tv kind_co r <- co
+etaForAllCo_ty_maybe co
+  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co
   = Just (tv, kind_co, r)
 
   | Pair ty1 ty2  <- coercionKind co
-  , Just (tv1, _) <- splitForAllTy_maybe ty1
-  , isForAllTy ty2
-  , let kind_co = mkNthCo 0 co
+  , Just (tv1, _) <- splitForAllTy_ty_maybe ty1
+  , isForAllTy_ty ty2
+  , let kind_co = mkNthCo Nominal 0 co
   = Just ( tv1, kind_co
-         , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) )
+         , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))
+
+  | otherwise
+  = Nothing
+
+etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
+-- Try to make the coercion be of form (forall cv:kind_co. co)
+etaForAllCo_co_maybe co
+  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co
+  = Just (cv, kind_co, r)
+
+  | Pair ty1 ty2  <- coercionKind co
+  , Just (cv1, _) <- splitForAllTy_co_maybe ty1
+  , isForAllTy_co ty2
+  = let kind_co  = mkNthCo Nominal 0 co
+        r        = coVarRole cv1
+        l_co     = mkCoVarCo cv1
+        kind_co' = downgradeRole r Nominal kind_co
+        r_co     = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo`
+                   l_co `mkTransCo`
+                   (mkNthCo r 3 kind_co')
+    in Just ( cv1, kind_co
+            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))
 
   | otherwise
   = Nothing
@@ -933,9 +1155,11 @@ etaTyConAppCo_maybe tc co
   , tc1 == tc2
   , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep
   , let n = length tys1
+  , tys2 `lengthIs` n      -- This can fail in an erroneous progam
+                           -- E.g. T a ~# T a b
+                           -- Trac #14607
   = ASSERT( tc == tc1 )
-    ASSERT( tys2 `lengthIs` n )
-    Just (decomposeCo n co)
+    Just (decomposeCo n co (tyConRolesX r tc1))
     -- NB: n might be <> tyConArity tc
     -- e.g.   data family T a :: * -> *
     --        g :: T a b ~ T c d
@@ -968,6 +1192,6 @@ and these two imply
 -}
 
 optForAllCoBndr :: LiftingContext -> Bool
-                -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
+                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)
 optForAllCoBndr env sym
-  = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env
+  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 5ac63e5b04..b50327fc37 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -18,7 +18,6 @@ Note [The Type-related module hierarchy]
 -- We expose the relevant stuff from this module via the Type module
 {-# OPTIONS_HADDOCK hide #-}
 {-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf #-}
-{-# LANGUAGE ImplicitParams #-}
 
 module TyCoRep (
         TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,
@@ -27,45 +26,55 @@ module TyCoRep (
         Type(..),
         TyLit(..),
         KindOrType, Kind,
+        KnotTied,
         PredType, ThetaType,      -- Synonyms
         ArgFlag(..),
 
         -- * Coercions
         Coercion(..),
-        UnivCoProvenance(..), CoercionHole(..),
+        UnivCoProvenance(..),
+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
         CoercionN, CoercionR, CoercionP, KindCoercion,
+        MCoercion(..), MCoercionR, MCoercionN,
 
         -- * Functions over types
         mkTyConTy, mkTyVarTy, mkTyVarTys,
-        mkFunTy, mkFunTys, mkForAllTy, mkForAllTys,
-        mkPiTy, mkPiTys,
+        mkTyCoVarTy, mkTyCoVarTys,
+        mkFunTy, mkFunTys, mkTyCoForAllTy, mkForAllTys,
+        mkForAllTy,
+        mkTyCoPiTy, mkTyCoPiTys,
+        mkPiTys,
+        isTYPE,
         isLiftedTypeKind, isUnliftedTypeKind,
         isCoercionType, isRuntimeRepTy, isRuntimeRepVar,
-        isRuntimeRepKindedTy, dropRuntimeRepArgs,
         sameVis,
 
         -- * Functions over binders
-        TyBinder(..), TyVarBinder,
-        binderVar, binderVars, binderKind, binderArgFlag,
+        TyCoBinder(..), TyCoVarBinder, TyBinder,
+        binderVar, binderVars, binderType, binderArgFlag,
         delBinderVar,
         isInvisibleArgFlag, isVisibleArgFlag,
         isInvisibleBinder, isVisibleBinder,
+        isTyBinder,
 
         -- * Functions over coercions
         pickLR,
 
         -- * Pretty-printing
         pprType, pprParendType, pprPrecType,
-        pprTypeApp, pprTvBndr, pprTvBndrs,
+        pprTypeApp, pprTCvBndr, pprTCvBndrs,
         pprSigmaType,
         pprTheta, pprParendTheta, pprForAll, pprUserForAll,
         pprTyVar, pprTyVars,
         pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprTyLit,
-        TyPrec(..), maybeParen, pprTcAppCo,
-        pprPrefixApp, pprArrowChain,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
         pprDataCons, ppSuggestExplicitKinds,
 
+        pprCo, pprParendCo,
+
+        debugPprType,
+
         -- * Free variables
         tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet,
         tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList,
@@ -78,6 +87,7 @@ module TyCoRep (
         tyCoFVsOfCo, tyCoFVsOfCos,
         tyCoVarsOfCoList, tyCoVarsOfProv,
         closeOverKinds,
+        injectiveVarsOfBinder, injectiveVarsOfType,
 
         noFreeVarsOfType, noFreeVarsOfCo,
 
@@ -85,18 +95,20 @@ module TyCoRep (
         TCvSubst(..), TvSubstEnv, CvSubstEnv,
         emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst,
         emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst,
-        mkTCvSubst, mkTvSubst,
+        mkTCvSubst, mkTvSubst, mkCvSubst,
         getTvSubstEnv,
         getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,
         isInScope, notElemTCvSubst,
         setTvSubstEnv, setCvSubstEnv, zapTCvSubst,
         extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,
-        extendTCvSubst,
+        extendTCvSubst, extendTCvSubstWithClone,
         extendCvSubst, extendCvSubstWithClone,
-        extendTvSubst, extendTvSubstBinder, extendTvSubstWithClone,
+        extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone,
         extendTvSubstList, extendTvSubstAndInScope,
+        extendTCvSubstList,
         unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet,
         zipTvSubst, zipCvSubst,
+        zipTCvSubst,
         mkTvSubstPrs,
 
         substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,
@@ -107,25 +119,28 @@ module TyCoRep (
         substCoUnchecked, substCoWithUnchecked,
         substTyWithInScope,
         substTys, substTheta,
-        lookupTyVar, substTyVarBndr,
+        lookupTyVar,
         substCo, substCos, substCoVar, substCoVars, lookupCoVar,
-        substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs,
-        substTyVar, substTyVars,
+        cloneTyVarBndr, cloneTyVarBndrs,
+        substVarBndr, substVarBndrs,
+        substTyVarBndr, substTyVarBndrs,
+        substCoVarBndr,
+        substTyVar, substTyVars, substTyCoVars,
         substForAllCoBndr,
-        substTyVarBndrCallback, substForAllCoBndrCallback,
+        substVarBndrUsing, substForAllCoBndrUsing,
         checkValidSubst, isValidTCvSubst,
 
         -- * Tidying type related things up for printing
         tidyType,      tidyTypes,
         tidyOpenType,  tidyOpenTypes,
         tidyOpenKind,
-        tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars,
+        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,
         tidyOpenTyCoVar, tidyOpenTyCoVars,
-        tidyTyVarOcc,
+        tidyTyCoVarOcc,
         tidyTopType,
         tidyKind,
         tidyCo, tidyCos,
-        tidyTyVarBinder, tidyTyVarBinders,
+        tidyTyCoVarBinder, tidyTyCoVarBinders,
 
         -- * Sizes
         typeSize, coercionSize, provSize
@@ -133,19 +148,22 @@ module TyCoRep (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} DataCon( dataConFullSig
-                             , dataConUnivTyVarBinders, dataConExTyVarBinders
-                             , DataCon, filterEqSpec )
+                             , dataConUserTyVarBinders
+                             , DataCon )
 import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy, mkCastTy
-                          , tyCoVarsOfTypesWellScoped
                           , tyCoVarsOfTypeWellScoped
-                          , coreView, typeKind )
+                          , tyCoVarsOfTypesWellScoped
+                          , toposortTyVars
+                          , coreView )
    -- Transitively pulls in a LOT of stuff, better to break the loop
 
 import {-# SOURCE #-} Coercion
 import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName )
 import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr
-                             , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercion )
+                             , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
 
 -- friends:
 import IfaceType
@@ -159,7 +177,8 @@ import CoAxiom
 import FV
 
 -- others
-import BasicTypes ( LeftOrRight(..), TyPrec(..), maybeParen, pickLR )
+import BasicTypes ( LeftOrRight(..), PprPrec(..), topPrec, sigPrec, opPrec
+                  , funPrec, appPrec, maybeParen, pickLR )
 import PrelNames
 import Outputable
 import DynFlags
@@ -258,8 +277,10 @@ data Type
         Type
         Type            -- ^ Type application to something other than a 'TyCon'. Parameters:
                         --
-                        --  1) Function: must /not/ be a 'TyConApp',
+                        --  1) Function: must /not/ be a 'TyConApp' or 'CastTy',
                         --     must be another 'AppTy', or 'TyVarTy'
+                        --     See Note [Respecting definitional equality] (EQ1) about the
+                        --     no 'CastTy' requirement
                         --
                         --  2) Argument type
 
@@ -281,7 +302,7 @@ data Type
                         --    can appear as the right hand side of a type synonym.
 
   | ForAllTy
-        {-# UNPACK #-} !TyVarBinder
+        {-# UNPACK #-} !TyCoVarBinder
         Type            -- ^ A Π type.
 
   | FunTy Type Type     -- ^ t1 -> t2   Very common, so an important special case
@@ -292,8 +313,8 @@ data Type
         Type
         KindCoercion  -- ^ A kind cast. The coercion is always nominal.
                       -- INVARIANT: The cast is never refl.
-                      -- INVARIANT: The cast is "pushed down" as far as it
-                      -- can go. See Note [Pushing down casts]
+                      -- INVARIANT: The Type is not a CastTy (use TransCo instead)
+                      -- See Note [Respecting definitional equality] (EQ2) and (EQ3)
 
   | CoercionTy
         Coercion    -- ^ Injection of a Coercion into a type
@@ -333,19 +354,12 @@ kinds or types.
 
 This kind instantiation only happens in TyConApp currently.
 
-Note [Pushing down casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have (a :: k1 -> *), (b :: k1), and (co :: * ~ q).
-The type (a b |> co) is `eqType` to ((a |> co') b), where
-co' = (->) <k1> co. Thus, to make this visible to functions
-that inspect types, we always push down coercions, preferring
-the second form. Note that this also applies to TyConApps!
-
 Note [Non-trivial definitional equality]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Is Int |> <*> the same as Int? YES! In order to reduce headaches,
-we decide that any reflexive casts in types are just ignored. More
-generally, the `eqType` function, which defines Core's type equality
+we decide that any reflexive casts in types are just ignored.
+(Indeed they must be. See Note [Respecting definitional equality].)
+More generally, the `eqType` function, which defines Core's type equality
 relation, ignores casts and coercion arguments, as long as the
 two types have the same kind. This allows us to be a little sloppier
 in keeping track of coercions, which is a good thing. It also means
@@ -357,11 +371,11 @@ appropriate for the implementation of eqType?
 Anything smaller than ~ and homogeneous is an appropriate definition for
 equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any
 expression of type τ can be transmuted to one of type σ at any point by
-casting. The same is true of types of type τ. So in some sense, τ and σ are
-interchangeable.
+casting. The same is true of expressions of type σ. So in some sense, τ and σ
+are interchangeable.
 
 But let's be more precise. If we examine the typing rules of FC (say, those in
-http://www.cis.upenn.edu/~eir/papers/2015/equalities/equalities-extended.pdf)
+https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf)
 there are several places where the same metavariable is used in two different
 premises to a rule. (For example, see Ty_App.) There is an implicit equality
 check here. What definition of equality should we use? By convention, we use
@@ -378,6 +392,9 @@ The effect of this all is that eqType, the implementation of the implicit
 equality check, can use any homogeneous relation that is smaller than ~, as
 those rules must also be admissible.
 
+A more drawn out argument around all of this is presented in Section 7.2 of
+Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf).
+
 What would go wrong if we insisted on the casts matching? See the beginning of
 Section 8 in the unpublished paper above. Theoretically, nothing at all goes
 wrong. But in practical terms, getting the coercions right proved to be
@@ -398,48 +415,145 @@ constructors and destructors in Type respect whatever relation is chosen.
 
 Another helpful principle with eqType is this:
 
- ** If (t1 eqType t2) then I can replace t1 by t2 anywhere. **
+ (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere.
 
 This principle also tells us that eqType must relate only types with the
 same kinds.
+
+Note [Respecting definitional equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Non-trivial definitional equality] introduces the property (EQ).
+How is this upheld?
+
+Any function that pattern matches on all the constructors will have to
+consider the possibility of CastTy. Presumably, those functions will handle
+CastTy appropriately and we'll be OK.
+
+More dangerous are the splitXXX functions. Let's focus on splitTyConApp.
+We don't want it to fail on (T a b c |> co). Happily, if we have
+  (T a b c |> co) `eqType` (T d e f)
+then co must be reflexive. Why? eqType checks that the kinds are equal, as
+well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).
+By the kind check, we know that (T a b c |> co) and (T d e f) have the same
+kind. So the only way that co could be non-reflexive is for (T a b c) to have
+a different kind than (T d e f). But because T's kind is closed (all tycon kinds
+are closed), the only way for this to happen is that one of the arguments has
+to differ, leading to a contradiction. Thus, co is reflexive.
+
+Accordingly, by eliminating reflexive casts, splitTyConApp need not worry
+about outermost casts to uphold (EQ). Eliminating reflexive casts is done
+in mkCastTy.
+
+Unforunately, that's not the end of the story. Consider comparing
+  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)
+These two types have the same kind (Type), but the left type is a TyConApp
+while the right type is not. To handle this case, we say that the right-hand
+type is ill-formed, requiring an AppTy never to have a casted TyConApp
+on its left. It is easy enough to pull around the coercions to maintain
+this invariant, as done in Type.mkAppTy. In the example above, trying to
+form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).
+Both the casts there are reflexive and will be dropped. Huzzah.
+
+This idea of pulling coercions to the right works for splitAppTy as well.
+
+However, there is one hiccup: it's possible that a coercion doesn't relate two
+Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,
+then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't
+be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not
+`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate
+our (EQ) property.
+
+Lastly, in order to detect reflexive casts reliably, we must make sure not
+to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).
+
+In sum, in order to uphold (EQ), we need the following three invariants:
+
+  (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable
+        cast is one that relates either a FunTy to a FunTy or a
+        ForAllTy to a ForAllTy.
+  (EQ2) No reflexive casts in CastTy.
+  (EQ3) No nested CastTys.
+  (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).
+        See Note [Weird typing rule for ForAllTy] in Type.
+
+These invariants are all documented above, in the declaration for Type.
+
+Note [Unused coercion variable in ForAllTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  \(co:t1 ~ t2). e
+
+What type should we give to this expression?
+  (1) forall (co:t1 ~ t2) -> t
+  (2) (t1 ~ t2) -> t
+
+If co is used in t, (1) should be the right choice.
+if co is not used in t, we would like to have (1) and (2) equivalent.
+
+However, we want to keep eqType simple and don't want eqType (1) (2) to return
+True in any case.
+
+We decide to always construct (2) if co is not used in t.
+
+Thus in mkTyCoForAllTy, we check whether the variable is a coercion
+variable and whether it is used in the body. If so, it returns a FunTy
+instead of a ForAllTy.
+
+There are cases we want to skip the check. For example, the check is unnecessary
+when it is known from the context that the input variable is a type variable.
+In those cases, we use mkForAllTy.
 -}
 
+-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See
+-- Note [Type checking recursive type and class declarations] in
+-- TcTyClsDecls
+type KnotTied ty = ty
+
 {- **********************************************************************
 *                                                                       *
-                  TyBinder and ArgFlag
+                  TyCoBinder and ArgFlag
 *                                                                       *
 ********************************************************************** -}
 
--- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent
--- ('Named') or nondependent ('Anon'). They may also be visible or not.
--- See Note [TyBinders]
-data TyBinder
-  = Named TyVarBinder   -- A type-lambda binder
-  | Anon Type           -- A term-lambda binder
+-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be
+-- dependent ('Named') or nondependent ('Anon'). They may also be visible or
+-- not. See Note [TyCoBinders]
+data TyCoBinder
+  = Named TyCoVarBinder -- A type-lambda binder
+  | Anon Type           -- A term-lambda binder. Type here can be CoercionTy.
                         -- Visibility is determined by the type (Constraint vs. *)
   deriving Data.Data
 
+-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'
+-- in the 'Named' field.
+type TyBinder = TyCoBinder
+
 -- | Remove the binder's variable from the set, if the binder has
 -- a variable.
-delBinderVar :: VarSet -> TyVarBinder -> VarSet
-delBinderVar vars (TvBndr tv _) = vars `delVarSet` tv
+delBinderVar :: VarSet -> TyCoVarBinder -> VarSet
+delBinderVar vars (Bndr tv _) = vars `delVarSet` tv
 
 -- | Does this binder bind an invisible argument?
-isInvisibleBinder :: TyBinder -> Bool
-isInvisibleBinder (Named (TvBndr _ vis)) = isInvisibleArgFlag vis
-isInvisibleBinder (Anon ty)              = isPredTy ty
+isInvisibleBinder :: TyCoBinder -> Bool
+isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis
+isInvisibleBinder (Anon ty)            = isPredTy ty
 
 -- | Does this binder bind a visible argument?
-isVisibleBinder :: TyBinder -> Bool
+isVisibleBinder :: TyCoBinder -> Bool
 isVisibleBinder = not . isInvisibleBinder
 
+-- | If its a named binder, is the binder a tyvar?
+-- Returns True for nondependent binder.
+isTyBinder :: TyCoBinder -> Bool
+isTyBinder (Named bnd) = isTyVarBinder bnd
+isTyBinder _ = True
 
-{- Note [TyBinders]
+{- Note [TyCoBinders]
 ~~~~~~~~~~~~~~~~~~~
-A ForAllTy contains a TyVarBinder.  But a type can be decomposed
-to a telescope consisting of a [TyBinder]
+A ForAllTy contains a TyCoVarBinder.  But a type can be decomposed
+to a telescope consisting of a [TyCoBinder]
 
-A TyBinder represents the type of binders -- that is, the type of an
+A TyCoBinder represents the type of binders -- that is, the type of an
 argument to a Pi-type. GHC Core currently supports two different
 Pi-types:
 
@@ -457,36 +571,47 @@ words, if `x` is either a function or a polytype, `x arg` makes sense
 (for an appropriate `arg`).
 
 
-Note [TyBinders and ArgFlags]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A ForAllTy contains a TyVarBinder.  Each TyVarBinder is equipped
-with a ArgFlag, which says whether or not arguments for this
-binder should be visible (explicit) in source Haskell.
-
------------------------------------------------------------------------
-                                            Occurrences look like this
- TyBinder          GHC displays type as     in Haskell souce code
------------------------------------------------------------------------
-In the type of a term
- Anon:             f :: type -> type         Arg required:     f x
- Named Inferred:   f :: forall {a}. type     Arg not allowed:  f
- Named Specified:  f :: forall a. type       Arg optional:     f  or  f @Int
- Named Required:         Illegal: See Note [No Required TyBinder in terms]
-
-In the kind of a type
- Anon:             T :: kind -> kind         Required:            T *
- Named Inferred:   T :: forall {k}. kind     Arg not allowed:     T
- Named Specified:  T :: forall k. kind       Arg not allowed[1]:  T
- Named Required:   T :: forall k -> kind     Required:            T *
-------------------------------------------------------------------------
+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder.
+  Each TyCoVarBinder
+      Bndr a tvis
+  is equipped with tvis::ArgFlag, which says whether or not arguments
+  for this binder should be visible (explicit) in source Haskell.
+
+* A TyCon contains a list of TyConBinders.  Each TyConBinder
+      Bndr a cvis
+  is equipped with cvis::TyConBndrVis, which says whether or not type
+  and kind arguments for this TyCon should be visible (explicit) in
+  source Haskell.
+
+This table summarises the visibility rules:
+---------------------------------------------------------------------------------------
+|                                                      Occurrences look like this
+|                             GHC displays type as     in Haskell source code
+|--------------------------------------------------------------------------------------
+| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term
+|  tvis :: ArgFlag
+|  tvis = Inferred:            f :: forall {a}. type    Arg not allowed:  f
+                               f :: forall {co}. type   Arg not allowed:  f
+|  tvis = Specified:           f :: forall a. type      Arg optional:     f  or  f @Int
+|  tvis = Required:            T :: forall k -> type    Arg required:     T *
+|    This last form is illegal in terms: See Note [No Required TyCoBinder in terms]
+|
+| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon
+|  cvis :: TyConBndrVis
+|  cvis = AnonTCB:             T :: kind -> kind        Required:            T *
+|  cvis = NamedTCB Inferred:   T :: forall {k}. kind    Arg not allowed:     T
+|                              T :: forall {co}. kind   Arg not allowed:     T
+|  cvis = NamedTCB Specified:  T :: forall k. kind      Arg not allowed[1]:  T
+|  cvis = NamedTCB Required:   T :: forall k -> kind    Required:            T *
+---------------------------------------------------------------------------------------
 
 [1] In types, in the Specified case, it would make sense to allow
     optional kind applications, thus (T @*), but we have not
     yet implemented that
 
----- Examples of where the different visibilities come from -----
-
-In term declarations:
+---- In term declarations ----
 
 * Inferred.  Function defn, with no signature:  f1 x = x
   We infer f1 :: forall {a}. a -> a, with 'a' Inferred
@@ -495,12 +620,12 @@ In term declarations:
 
 * Specified.  Function defn, with signature (implicit forall):
      f2 :: a -> a; f2 x = x
-  So f2 gets the type f2 :: forall a. a->a, with 'a' Specified
+  So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified
   even though 'a' is not bound in the source code by an explicit forall
 
 * Specified.  Function defn, with signature (explicit forall):
      f3 :: forall a. a -> a; f3 x = x
-  So f3 gets the type f3 :: forall a. a->a, with 'a' Specified
+  So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified
 
 * Inferred/Specified.  Function signature with inferred kind polymorphism.
      f4 :: a b -> Int
@@ -517,14 +642,14 @@ In term declarations:
   Inferred - from inferred types (e.g. no pattern type signature)
            - or from inferred kind polymorphism
 
-In type declarations:
+---- In type declarations ----
 
 * Inferred (k)
      data T1 a b = MkT1 (a b)
   Here T1's kind is  T1 :: forall {k:*}. (k->*) -> k -> *
   The kind variable 'k' is Inferred, since it is not mentioned
 
-  Note that 'a' and 'b' correspond to /Anon/ TyBinders in T1's kind,
+  Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind,
   and Anon binders don't have a visibility flag. (Or you could think
   of Anon having an implicit Required flag.)
 
@@ -546,6 +671,19 @@ In type declarations:
   So 'k' is Specified, because it appears explicitly,
   but 'k1' is Inferred, because it does not
 
+Generally, in the list of TyConBinders for a TyCon,
+
+* Inferred arguments always come first
+* Specified, Anon and Required can be mixed
+
+e.g.
+  data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ...
+
+Here Foo's TyConBinders are
+   [Required 'a', Specified 'b', Anon]
+and its kind prints as
+   Foo :: forall a -> forall b. (a -> b -> Type) -> Type
+
 ---- Printing -----
 
  We print forall types with enough syntax to tell you their visibility
@@ -571,14 +709,14 @@ In type declarations:
 * Inferred variables correspond to "generalized" variables from the
   Visible Type Applications paper (ESOP'16).
 
-Note [No Required TyBinder in terms]
+Note [No Required TyCoBinder in terms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We don't allow Required foralls for term variables, including pattern
 synonyms and data constructors.  Why?  Because then an application
 would need a /compulsory/ type argument (possibly without an "@"?),
 thus (f Int); and we don't have concrete syntax for that.
 
-We could change this decision, but Required, Named TyBinders are rare
+We could change this decision, but Required, Named TyCoBinders are rare
 anyway.  (Most are Anons.)
 -}
 
@@ -639,14 +777,23 @@ These functions are here so that they can be used by TysPrim,
 which in turn is imported by Type
 -}
 
--- named with "Only" to prevent naive use of mkTyVarTy
 mkTyVarTy  :: TyVar   -> Type
 mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) )
-                  TyVarTy v
+              TyVarTy v
 
 mkTyVarTys :: [TyVar] -> [Type]
 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 
+mkTyCoVarTy :: TyCoVar -> Type
+mkTyCoVarTy v
+  | isTyVar v
+  = TyVarTy v
+  | otherwise
+  = CoercionTy (CoVarCo v)
+
+mkTyCoVarTys :: [TyCoVar] -> [Type]
+mkTyCoVarTys = map mkTyCoVarTy
+
 infixr 3 `mkFunTy`      -- Associates to the right
 -- | Make an arrow type
 mkFunTy :: Type -> Type -> Type
@@ -656,18 +803,41 @@ mkFunTy arg res = FunTy arg res
 mkFunTys :: [Type] -> Type -> Type
 mkFunTys tys ty = foldr mkFunTy ty tys
 
-mkForAllTy :: TyVar -> ArgFlag -> Type -> Type
-mkForAllTy tv vis ty = ForAllTy (TvBndr tv vis) ty
+-- | If tv is a coercion variable and it is not used in the body, returns
+-- a FunTy, otherwise makes a forall type.
+-- See Note [Unused coercion variable in ForAllTy]
+mkTyCoForAllTy :: TyCoVar -> ArgFlag -> Type -> Type
+mkTyCoForAllTy tv vis ty
+  | isCoVar tv
+  , not (tv `elemVarSet` tyCoVarsOfType ty)
+  = ASSERT( vis == Inferred )
+    mkFunTy (varType tv) ty
+  | otherwise
+  = ForAllTy (Bndr tv vis) ty
 
--- | Wraps foralls over the type using the provided 'TyVar's from left to right
-mkForAllTys :: [TyVarBinder] -> Type -> Type
+-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder
+-- See Note [Unused coercion variable in ForAllTy]
+mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type
+mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty
+
+-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right
+mkForAllTys :: [TyCoVarBinder] -> Type -> Type
 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 
-mkPiTy :: TyBinder -> Type -> Type
-mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2
-mkPiTy (Named tvb) ty = ForAllTy tvb ty
+mkTyCoPiTy :: TyCoBinder -> Type -> Type
+mkTyCoPiTy (Anon ty1) ty2           = FunTy ty1 ty2
+mkTyCoPiTy (Named (Bndr tv vis)) ty = mkTyCoForAllTy tv vis ty
+
+-- | Like 'mkTyCoPiTy', but does not check the occurrence of the binder
+mkPiTy:: TyCoBinder -> Type -> Type
+mkPiTy (Anon ty1) ty2           = FunTy ty1 ty2
+mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty
 
-mkPiTys :: [TyBinder] -> Type -> Type
+mkTyCoPiTys :: [TyCoBinder] -> Type -> Type
+mkTyCoPiTys tbs ty = foldr mkTyCoPiTy ty tbs
+
+-- | Like 'mkTyCoPiTys', but does not check the occurrence of the binder
+mkPiTys :: [TyCoBinder] -> Type -> Type
 mkPiTys tbs ty = foldr mkPiTy ty tbs
 
 -- | Does this type classify a core (unlifted) Coercion?
@@ -689,22 +859,28 @@ mkTyConTy tycon = TyConApp tycon []
 Some basic functions, put here to break loops eg with the pretty printer
 -}
 
-is_TYPE :: (   Type    -- the single argument to TYPE; not a synonym
-            -> Bool )  -- what to return
-        -> Kind -> Bool
-is_TYPE f ki | Just ki' <- coreView ki = is_TYPE f ki'
-is_TYPE f (TyConApp tc [arg])
+-- | If a type is @'TYPE' r@ for some @r@, run the predicate argument on @r@.
+-- Otherwise, return 'False'.
+--
+-- This function does not distinguish between 'Constraint' and 'Type'. For a
+-- version which does distinguish between the two, see 'tcIsTYPE'.
+isTYPE :: (   Type    -- the single argument to TYPE; not a synonym
+           -> Bool )  -- what to return
+       -> Kind -> Bool
+isTYPE f ki | Just ki' <- coreView ki = isTYPE f ki'
+isTYPE f (TyConApp tc [arg])
   | tc `hasKey` tYPETyConKey
   = go arg
     where
       go ty | Just ty' <- coreView ty = go ty'
       go ty = f ty
-is_TYPE _ _ = False
+isTYPE _ _ = False
 
--- | This version considers Constraint to be distinct from *. Returns True
--- if the argument is equivalent to Type and False otherwise.
+-- | This version considers Constraint to be the same as *. Returns True
+-- if the argument is equivalent to Type/Constraint and False otherwise.
+-- See Note [Kind Constraint and kind Type]
 isLiftedTypeKind :: Kind -> Bool
-isLiftedTypeKind = is_TYPE is_lifted
+isLiftedTypeKind = isTYPE is_lifted
   where
     is_lifted (TyConApp lifted_rep []) = lifted_rep `hasKey` liftedRepDataConKey
     is_lifted _                        = False
@@ -713,9 +889,9 @@ isLiftedTypeKind = is_TYPE is_lifted
 -- Note that this returns False for levity-polymorphic kinds, which may
 -- be specialized to a kind that classifies unlifted types.
 isUnliftedTypeKind :: Kind -> Bool
-isUnliftedTypeKind = is_TYPE is_unlifted
+isUnliftedTypeKind = isTYPE is_unlifted
   where
-    is_unlifted (TyConApp rr _args) = not (rr `hasKey` liftedRepDataConKey)
+    is_unlifted (TyConApp rr _args) = elem (getUnique rr) unliftedRepDataConKeys
     is_unlifted _                   = False
 
 -- | Is this the type 'RuntimeRep'?
@@ -724,23 +900,10 @@ isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty'
 isRuntimeRepTy (TyConApp tc []) = tc `hasKey` runtimeRepTyConKey
 isRuntimeRepTy _ = False
 
--- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)
-isRuntimeRepKindedTy :: Type -> Bool
-isRuntimeRepKindedTy = isRuntimeRepTy . typeKind
-
 -- | Is a tyvar of type 'RuntimeRep'?
 isRuntimeRepVar :: TyVar -> Bool
 isRuntimeRepVar = isRuntimeRepTy . tyVarKind
 
--- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.
--- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:
---
---   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep
---                      , String, Int# ] == [String, Int#]
---
-dropRuntimeRepArgs :: [Type] -> [Type]
-dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy
-
 {-
 %************************************************************************
 %*                                                                      *
@@ -764,8 +927,8 @@ data Coercion
   --    -   _ stands for a parameter that is not a Role or Coercion.
 
   -- These ones mirror the shape of types
-  = -- Refl :: "e" -> _ -> e
-    Refl Role Type  -- See Note [Refl invariant]
+  = -- Refl :: _ -> N
+    Refl Type  -- See Note [Refl invariant]
           -- Invariant: applications of (Refl T) to a bunch of identity coercions
           --            always show up as Refl.
           -- For example  (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).
@@ -776,7 +939,13 @@ data Coercion
           -- ConAppCo coercions (like all coercions other than Refl)
           -- are NEVER the identity.
 
-          -- Use (Refl Representational _), not (SubCo (Refl Nominal _))
+          -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty))
+
+  -- GRefl :: "e" -> _ -> Maybe N -> e
+  -- See Note [Generalized reflexive coercion]
+  | GRefl Role Type MCoercionN  -- See Note [Refl invariant]
+          -- Use (Refl ty), not (GRefl Nominal ty MRefl)
+          -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))
 
   -- These ones simply lift the correspondingly-named
   -- Type constructors into Coercions
@@ -792,7 +961,7 @@ data Coercion
           -- AppCo :: e -> N -> e
 
   -- See Note [Forall coercions]
-  | ForAllCo TyVar KindCoercion Coercion
+  | ForAllCo TyCoVar KindCoercion Coercion
          -- ForAllCo :: _ -> N -> e -> e
 
   | FunCo Role Coercion Coercion         -- lift FunTy
@@ -810,20 +979,25 @@ data Coercion
      -- any left over, we use AppCo.
      -- See [Coercion axioms applied to coercions]
 
+  | AxiomRuleCo CoAxiomRule [Coercion]
+    -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule
+    -- The number coercions should match exactly the expectations
+    -- of the CoAxiomRule (i.e., the rule is fully saturated).
+
   | UnivCo UnivCoProvenance Role Type Type
       -- :: _ -> "e" -> _ -> _ -> e
 
   | SymCo Coercion             -- :: e -> e
   | TransCo Coercion Coercion  -- :: e -> e -> e
 
-    -- The number coercions should match exactly the expectations
-    -- of the CoAxiomRule (i.e., the rule is fully saturated).
-  | AxiomRuleCo CoAxiomRule [Coercion]
-
-  | NthCo  Int         Coercion     -- Zero-indexed; decomposes (T t0 ... tn)
-    -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles])
+  | NthCo  Role Int Coercion     -- Zero-indexed; decomposes (T t0 ... tn)
+    -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles])
     -- Using NthCo on a ForAllCo gives an N coercion always
     -- See Note [NthCo and newtypes]
+    --
+    -- Invariant:  (NthCo r i co), it is always the case that r = role of (Nth i co)
+    -- That is: the role of the entire coercion is redundantly cached here.
+    -- See Note [NthCo Cached Roles]
 
   | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)
     -- :: _ -> N -> N
@@ -831,11 +1005,6 @@ data Coercion
     -- :: e -> N -> e
     -- See Note [InstCo roles]
 
-  -- Coherence applies a coercion to the left-hand type of another coercion
-  -- See Note [Coherence]
-  | CoherenceCo Coercion KindCoercion
-     -- :: e -> N -> e
-
   -- Extract a kind coercion from a (heterogeneous) type coercion
   -- NB: all kind coercions are Nominal
   | KindCo Coercion
@@ -844,6 +1013,8 @@ data Coercion
   | SubCo CoercionN                  -- Turns a ~N into a ~R
     -- :: N -> R
 
+  | HoleCo CoercionHole              -- ^ See Note [Coercion holes]
+                                     -- Only present during typechecking
   deriving Data.Data
 
 type CoercionN = Coercion       -- always nominal
@@ -851,13 +1022,28 @@ type CoercionR = Coercion       -- always representational
 type CoercionP = Coercion       -- always phantom
 type KindCoercion = CoercionN   -- always nominal
 
+-- | A semantically more meaningful type to represent what may or may not be a
+-- useful 'Coercion'.
+data MCoercion
+  = MRefl
+    -- A trivial Reflexivity coercion
+  | MCo Coercion
+    -- Other coercions
+  deriving Data.Data
+type MCoercionR = MCoercion
+type MCoercionN = MCoercion
+
+instance Outputable MCoercion where
+  ppr MRefl    = text "MRefl"
+  ppr (MCo co) = text "MCo" <+> ppr co
+
 {-
 Note [Refl invariant]
 ~~~~~~~~~~~~~~~~~~~~~
 Invariant 1:
 
 Coercions have the following invariant
-     Refl is always lifted as far as possible.
+     Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.
 
 You might think that a consequencs is:
      Every identity coercions has Refl at the root
@@ -868,6 +1054,42 @@ But that's not quite true because of coercion variables.  Consider
 etc.  So the consequence is only true of coercions that
 have no coercion variables.
 
+Note [Generalized reflexive coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GRefl is a generalized reflexive coercion (see Trac #15192). It wraps a kind
+coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing
+rules for GRefl:
+
+  ty : k1
+  ------------------------------------
+  GRefl r ty MRefl: ty ~r ty
+
+  ty : k1       co :: k1 ~ k2
+  ------------------------------------
+  GRefl r ty (MCo co) : ty ~r ty |> co
+
+Consider we have
+
+   g1 :: s ~r t
+   s  :: k1
+   g2 :: k1 ~ k2
+
+and we want to construct a coercions co which has type
+
+   (s |> g2) ~r t
+
+We can define
+
+   co = Sym (GRefl r s g2) ; g1
+
+It is easy to see that
+
+   Refl == GRefl Nominal ty MRefl :: ty ~n ty
+
+A nominal reflexive coercion is quite common, so we keep the special form Refl to
+save allocation.
+
 Note [Coercion axioms applied to coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The reason coercion axioms can be applied to coercions and not just
@@ -936,9 +1158,10 @@ The typing rule is:
   ForAllCo tv1 kind_co co : all tv1:k1. t1  ~
                             all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])
 
-First, the TyVar stored in a ForAllCo is really an optimisation: this field
+First, the TyCoVar stored in a ForAllCo is really an optimisation: this field
 should be a Name, as its kind is redundant. Thinking of the field as a Name
 is helpful in understanding what a ForAllCo means.
+The kind of TyCoVar always matches the left-hand kind of the coercion.
 
 The idea is that kind_co gives the two kinds of the tyvar. See how, in the
 conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.
@@ -959,19 +1182,6 @@ add Names to, e.g., VarSets, and there generally is just an impedance mismatch
 in a bunch of places. So we use tv1. When we need tv2, we can use
 setTyVarKind.
 
-Note [Coherence]
-~~~~~~~~~~~~~~~~
-The Coherence typing rule is thus:
-
-  g1 : s ~ t    s : k1    g2 : k1 ~ k2
-  ------------------------------------
-  CoherenceCo g1 g2 : (s |> g2) ~ t
-
-While this looks (and is) unsymmetric, a combination of other coercion
-combinators can make the symmetric version.
-
-For role information, see Note [Roles and kind coercions].
-
 Note [Predicate coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have
@@ -1131,7 +1341,7 @@ We can then build
 for any `a` and `b`. Because of the role annotation on N, if we use
 NthCo, we'll get out a representational coercion. That is:
 
-  NthCo 0 co :: forall a b. a ~R b
+  NthCo r 0 co :: forall a b. a ~R b
 
 Yikes! Clearly, this is terrible. The solution is simple: forbid
 NthCo to be used on newtypes if the internal coercion is representational.
@@ -1140,6 +1350,23 @@ This is not just some corner case discovered by a segfault somewhere;
 it was discovered in the proof of soundness of roles and described
 in the "Safe Coercions" paper (ICFP '14).
 
+Note [NthCo Cached Roles]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we cache the role of NthCo in the NthCo constructor?
+Because computing role(Nth i co) involves figuring out that
+
+  co :: T tys1 ~ T tys2
+
+using coercionKind, and finding (coercionRole co), and then looking
+at the tyConRoles of T. Avoiding bad asymptotic behaviour here means
+we have to compute the kind and role of a coercion simultaneously,
+which makes the code complicated and inefficient.
+
+This only happens for NthCo. Caching the role solves the problem, and
+allows coercionKind and coercionRole to be simple.
+
+See Trac #11735
+
 Note [InstCo roles]
 ~~~~~~~~~~~~~~~~~~~
 Here is (essentially) the typing rule for InstCo:
@@ -1197,7 +1424,6 @@ data UnivCoProvenance
   | PluginProv String  -- ^ From a plugin, which asserts that this coercion
                        --   is sound. The string is for the use of the plugin.
 
-  | HoleProv CoercionHole  -- ^ See Note [Coercion holes]
   deriving Data.Data
 
 instance Outputable UnivCoProvenance where
@@ -1205,14 +1431,21 @@ instance Outputable UnivCoProvenance where
   ppr (PhantomProv _)    = text "(phantom)"
   ppr (ProofIrrelProv _) = text "(proof irrel.)"
   ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))
-  ppr (HoleProv hole)    = parens (text "hole" <> ppr hole)
 
 -- | A coercion to be filled in by the type-checker. See Note [Coercion holes]
 data CoercionHole
-  = CoercionHole { chUnique   :: Unique   -- ^ used only for debugging
-                 , chCoercion :: IORef (Maybe Coercion)
+  = CoercionHole { ch_co_var :: CoVar
+                       -- See Note [CoercionHoles and coercion free variables]
+
+                 , ch_ref    :: IORef (Maybe Coercion)
                  }
 
+coHoleCoVar :: CoercionHole -> CoVar
+coHoleCoVar = ch_co_var
+
+setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole
+setCoHoleCoVar h cv = h { ch_co_var = cv }
+
 instance Data.Data CoercionHole where
   -- don't traverse?
   toConstr _   = abstractConstr "CoercionHole"
@@ -1220,7 +1453,7 @@ instance Data.Data CoercionHole where
   dataTypeOf _ = mkNoRepType "CoercionHole"
 
 instance Outputable CoercionHole where
-  ppr (CoercionHole u _) = braces (ppr u)
+  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)
 
 
 {- Note [Phantom coercions]
@@ -1247,7 +1480,7 @@ During typechecking, constraint solving for type classes works by
 
 For equality constraints we use a different strategy.  See Note [The
 equality types story] in TysPrim for background on equality constraints.
-  - For boxed equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just
+  - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just
     like type classes above. (Indeed, boxed equality constraints *are* classes.)
   - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)
     we use a different plan
@@ -1256,40 +1489,61 @@ For unboxed equalities:
   - Generate a CoercionHole, a mutable variable just like a unification
     variable
   - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest
-  - Use the CoercionHole in a Coercion, via HoleProv
+  - Use the CoercionHole in a Coercion, via HoleCo
   - Solve the constraint later
   - When solved, fill in the CoercionHole by side effect, instead of
     doing the let-binding thing
 
 The main reason for all this is that there may be no good place to let-bind
 the evidence for unboxed equalities:
-  - We emit constraints for kind coercions, to be used
-    to cast a type's kind. These coercions then must be used in types. Because
-    they might appear in a top-level type, there is no place to bind these
-   (unlifted) coercions in the usual way.
 
-  - A coercion for (forall a. t1) ~ forall a. t2) will look like
+  - We emit constraints for kind coercions, to be used to cast a
+    type's kind. These coercions then must be used in types. Because
+    they might appear in a top-level type, there is no place to bind
+    these (unlifted) coercions in the usual way.
+
+  - A coercion for (forall a. t1) ~ (forall a. t2) will look like
        forall a. (coercion for t1~t2)
-    But the coercion for (t1~t2) may mention 'a', and we don't have let-bindings
-    within coercions.  We could add them, but coercion holes are easier.
+    But the coercion for (t1~t2) may mention 'a', and we don't have
+    let-bindings within coercions.  We could add them, but coercion
+    holes are easier.
+
+  - Moreover, nothing is lost from the lack of let-bindings. For
+    dicionaries want to achieve sharing to avoid recomoputing the
+    dictionary.  But coercions are entirely erased, so there's little
+    benefit to sharing. Indeed, even if we had a let-binding, we
+    always inline types and coercions at every use site and drop the
+    binding.
 
 Other notes about HoleCo:
 
- * INVARIANT: CoercionHole and HoleProv are used only during type checking,
+ * INVARIANT: CoercionHole and HoleCo are used only during type checking,
    and should never appear in Core. Just like unification variables; a Type
    can contain a TcTyVar, but only during type checking. If, one day, we
    use type-level information to separate out forms that can appear during
    type-checking vs forms that can appear in core proper, holes in Core will
    be ruled out.
 
- * The Unique carried with a coercion hole is used solely for debugging.
+ * See Note [CoercionHoles and coercion free variables]
 
- * Coercion holes can be compared for equality only like other coercions:
-   only by looking at the types coerced.
+ * Coercion holes can be compared for equality like other coercions:
+   by looking at the types coerced.
+
+
+Note [CoercionHoles and coercion free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Why does a CoercionHole contain a CoVar, as well as reference to
+fill in?  Because we want to treat that CoVar as a free variable of
+the coercion.  See Trac #14584, and Note [What prevents a
+constraint from floating] in TcSimplify, item (4):
+
+        forall k. [W] co1 :: t1 ~# t2 |> co2
+                  [W] co2 :: k ~# *
+
+Here co2 is a CoercionHole. But we /must/ know that it is free in
+co1, because that's all that stops it floating outside the
+implication.
 
- * We don't use holes for other evidence because other evidence wants to
-   be /shared/. But coercions are entirely erased, so there's little
-   benefit to sharing.
 
 Note [ProofIrrelProv]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -1304,7 +1558,7 @@ In core, we get
   MkG :: forall (a :: *). (a ~ Bool) -> G a
 
 Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want
-a proof that ('MkG co1 a1) ~ ('MkG co2 a2). This will have to be
+a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be
 
   TyConAppCo Nominal MkG [co3, co4]
   where
@@ -1319,7 +1573,7 @@ Here,
   co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2)
   where
     co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)
-    co5 = TyConAppCo Nominal (~) [<*>, <*>, co4, <Bool>]
+    co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>]
 
 
 %************************************************************************
@@ -1386,10 +1640,10 @@ tyCoFVsOfType (ForAllTy bndr ty) a b c = tyCoFVsBndr bndr (tyCoFVsOfType ty)  a
 tyCoFVsOfType (CastTy ty co)     a b c = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) a b c
 tyCoFVsOfType (CoercionTy co)    a b c = tyCoFVsOfCo co a b c
 
-tyCoFVsBndr :: TyVarBinder -> FV -> FV
+tyCoFVsBndr :: TyCoVarBinder -> FV -> FV
 -- Free vars of (forall b. <thing with fvs>)
-tyCoFVsBndr (TvBndr tv _) fvs = (delFV tv fvs)
-                                `unionFV` tyCoFVsOfType (tyVarKind tv)
+tyCoFVsBndr (Bndr tv _) fvs = (delFV tv fvs)
+                              `unionFV` tyCoFVsOfType (varType tv)
 
 -- | Returns free variables of types, including kind variables as
 -- a non-deterministic set. For type synonyms it does /not/ expand the
@@ -1439,10 +1693,17 @@ tyCoVarsOfCoList :: Coercion -> [TyCoVar]
 -- See Note [Free variables of types]
 tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co
 
+tyCoFVsOfMCo :: MCoercion -> FV
+tyCoFVsOfMCo MRefl    = emptyFV
+tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co
+
 tyCoFVsOfCo :: Coercion -> FV
 -- Extracts type and coercion variables from a coercion
 -- See Note [Free variables of types]
-tyCoFVsOfCo (Refl _ ty)         fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc
+tyCoFVsOfCo (Refl ty) fv_cand in_scope acc
+  = tyCoFVsOfType ty fv_cand in_scope acc
+tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc
+  = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc
 tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc
 tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc
   = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc
@@ -1451,21 +1712,27 @@ tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc
 tyCoFVsOfCo (FunCo _ co1 co2)    fv_cand in_scope acc
   = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc
 tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc
-  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
+  = tyCoFVsOfCoVar v fv_cand in_scope acc
+tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc
+  = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc
+    -- See Note [CoercionHoles and coercion free variables]
 tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc
 tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc
   = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1
-                         `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc
+                     `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc
 tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc
-tyCoFVsOfCo (NthCo _ co)        fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
+tyCoFVsOfCo (NthCo _ _ co)      fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfCo (LRCo _ co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc
-tyCoFVsOfCo (CoherenceCo c1 c2) fv_cand in_scope acc = (tyCoFVsOfCo c1 `unionFV` tyCoFVsOfCo c2) fv_cand in_scope acc
 tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc
 
+tyCoFVsOfCoVar :: CoVar -> FV
+tyCoFVsOfCoVar v fv_cand in_scope acc
+  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
+
 tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet
 tyCoVarsOfProv prov = fvVarSet $ tyCoFVsOfProv prov
 
@@ -1474,7 +1741,6 @@ tyCoFVsOfProv UnsafeCoerceProv    fv_cand in_scope acc = emptyFV fv_cand in_scop
 tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
 tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc
-tyCoFVsOfProv (HoleProv _)        fv_cand in_scope acc = emptyFV fv_cand in_scope acc
 
 tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
 tyCoVarsOfCos cos = fvVarSet $ tyCoFVsOfCos cos
@@ -1494,42 +1760,50 @@ coVarsOfType (TyConApp _ tys)    = coVarsOfTypes tys
 coVarsOfType (LitTy {})          = emptyVarSet
 coVarsOfType (AppTy fun arg)     = coVarsOfType fun `unionVarSet` coVarsOfType arg
 coVarsOfType (FunTy arg res)     = coVarsOfType arg `unionVarSet` coVarsOfType res
-coVarsOfType (ForAllTy (TvBndr tv _) ty)
+coVarsOfType (ForAllTy (Bndr tv _) ty)
   = (coVarsOfType ty `delVarSet` tv)
-    `unionVarSet` coVarsOfType (tyVarKind tv)
+    `unionVarSet` coVarsOfType (varType tv)
 coVarsOfType (CastTy ty co)      = coVarsOfType ty `unionVarSet` coVarsOfCo co
 coVarsOfType (CoercionTy co)     = coVarsOfCo co
 
 coVarsOfTypes :: [Type] -> TyCoVarSet
 coVarsOfTypes tys = mapUnionVarSet coVarsOfType tys
 
+coVarsOfMCo :: MCoercion -> CoVarSet
+coVarsOfMCo MRefl    = emptyVarSet
+coVarsOfMCo (MCo co) = coVarsOfCo co
+
 coVarsOfCo :: Coercion -> CoVarSet
 -- Extract *coercion* variables only.  Tiresome to repeat the code, but easy.
-coVarsOfCo (Refl _ ty)         = coVarsOfType ty
+coVarsOfCo (Refl ty)             = coVarsOfType ty
+coVarsOfCo (GRefl _ ty co)       = coVarsOfType ty `unionVarSet` coVarsOfMCo co
 coVarsOfCo (TyConAppCo _ _ args) = coVarsOfCos args
 coVarsOfCo (AppCo co arg)      = coVarsOfCo co `unionVarSet` coVarsOfCo arg
 coVarsOfCo (ForAllCo tv kind_co co)
   = coVarsOfCo co `delVarSet` tv `unionVarSet` coVarsOfCo kind_co
-coVarsOfCo (FunCo _ co1 co2)   = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
-coVarsOfCo (CoVarCo v)         = unitVarSet v `unionVarSet` coVarsOfType (varType v)
-coVarsOfCo (AxiomInstCo _ _ args) = coVarsOfCos args
-coVarsOfCo (UnivCo p _ t1 t2)  = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2]
-coVarsOfCo (SymCo co)          = coVarsOfCo co
-coVarsOfCo (TransCo co1 co2)   = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
-coVarsOfCo (NthCo _ co)        = coVarsOfCo co
-coVarsOfCo (LRCo _ co)         = coVarsOfCo co
-coVarsOfCo (InstCo co arg)     = coVarsOfCo co `unionVarSet` coVarsOfCo arg
-coVarsOfCo (CoherenceCo c1 c2) = coVarsOfCos [c1, c2]
-coVarsOfCo (KindCo co)         = coVarsOfCo co
-coVarsOfCo (SubCo co)          = coVarsOfCo co
-coVarsOfCo (AxiomRuleCo _ cs)  = coVarsOfCos cs
+coVarsOfCo (FunCo _ co1 co2)    = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (CoVarCo v)          = coVarsOfCoVar v
+coVarsOfCo (HoleCo h)           = coVarsOfCoVar (coHoleCoVar h)
+                                  -- See Note [CoercionHoles and coercion free variables]
+coVarsOfCo (AxiomInstCo _ _ as) = coVarsOfCos as
+coVarsOfCo (UnivCo p _ t1 t2)   = coVarsOfProv p `unionVarSet` coVarsOfTypes [t1, t2]
+coVarsOfCo (SymCo co)           = coVarsOfCo co
+coVarsOfCo (TransCo co1 co2)    = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (NthCo _ _ co)       = coVarsOfCo co
+coVarsOfCo (LRCo _ co)          = coVarsOfCo co
+coVarsOfCo (InstCo co arg)      = coVarsOfCo co `unionVarSet` coVarsOfCo arg
+coVarsOfCo (KindCo co)          = coVarsOfCo co
+coVarsOfCo (SubCo co)           = coVarsOfCo co
+coVarsOfCo (AxiomRuleCo _ cs)   = coVarsOfCos cs
+
+coVarsOfCoVar :: CoVar -> CoVarSet
+coVarsOfCoVar v = unitVarSet v `unionVarSet` coVarsOfType (varType v)
 
 coVarsOfProv :: UnivCoProvenance -> CoVarSet
 coVarsOfProv UnsafeCoerceProv    = emptyVarSet
 coVarsOfProv (PhantomProv co)    = coVarsOfCo co
 coVarsOfProv (ProofIrrelProv co) = coVarsOfCo co
 coVarsOfProv (PluginProv _)      = emptyVarSet
-coVarsOfProv (HoleProv _)        = emptyVarSet
 
 coVarsOfCos :: [Coercion] -> CoVarSet
 coVarsOfCos cos = mapUnionVarSet coVarsOfCo cos
@@ -1558,6 +1832,41 @@ closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs
 closeOverKindsDSet :: DTyVarSet -> DTyVarSet
 closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems
 
+-- | Returns the free variables of a 'TyConBinder' that are in injective
+-- positions. (See @Note [Kind annotations on TyConApps]@ in "TcSplice" for an
+-- explanation of what an injective position is.)
+injectiveVarsOfBinder :: TyConBinder -> FV
+injectiveVarsOfBinder (Bndr tv vis) =
+  case vis of
+    AnonTCB           -> injectiveVarsOfType (varType tv)
+    NamedTCB Required -> unitFV tv `unionFV`
+                         injectiveVarsOfType (varType tv)
+    NamedTCB _        -> emptyFV
+
+-- | Returns the free variables of a 'Type' that are in injective positions.
+-- (See @Note [Kind annotations on TyConApps]@ in "TcSplice" for an explanation
+-- of what an injective position is.)
+injectiveVarsOfType :: Type -> FV
+injectiveVarsOfType = go
+  where
+    go ty                | Just ty' <- coreView ty
+                         = go ty'
+    go (TyVarTy v)       = unitFV v `unionFV` go (tyVarKind v)
+    go (AppTy f a)       = go f `unionFV` go a
+    go (FunTy ty1 ty2)   = go ty1 `unionFV` go ty2
+    go (TyConApp tc tys) =
+      case tyConInjectivityInfo tc of
+        NotInjective  -> emptyFV
+        Injective inj -> mapUnionFV go $
+                         filterByList (inj ++ repeat True) tys
+                         -- Oversaturated arguments to a tycon are
+                         -- always injective, hence the repeat True
+    go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go (binderType tvb)
+                                             `unionFV` go ty
+    go LitTy{}           = emptyFV
+    go (CastTy ty _)     = go ty
+    go CoercionTy{}      = emptyFV
+
 -- | Returns True if this type has no free variables. Should be the same as
 -- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case.
 noFreeVarsOfType :: Type -> Bool
@@ -1570,25 +1879,33 @@ noFreeVarsOfType (LitTy _)        = True
 noFreeVarsOfType (CastTy ty co)   = noFreeVarsOfType ty && noFreeVarsOfCo co
 noFreeVarsOfType (CoercionTy co)  = noFreeVarsOfCo co
 
+noFreeVarsOfMCo :: MCoercion -> Bool
+noFreeVarsOfMCo MRefl    = True
+noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co
+
+noFreeVarsOfTypes :: [Type] -> Bool
+noFreeVarsOfTypes = all noFreeVarsOfType
+
 -- | Returns True if this coercion has no free variables. Should be the same as
 -- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case.
 noFreeVarsOfCo :: Coercion -> Bool
-noFreeVarsOfCo (Refl _ ty)            = noFreeVarsOfType ty
+noFreeVarsOfCo (Refl ty)              = noFreeVarsOfType ty
+noFreeVarsOfCo (GRefl _ ty co)        = noFreeVarsOfType ty && noFreeVarsOfMCo co
 noFreeVarsOfCo (TyConAppCo _ _ args)  = all noFreeVarsOfCo args
 noFreeVarsOfCo (AppCo c1 c2)          = noFreeVarsOfCo c1 && noFreeVarsOfCo c2
 noFreeVarsOfCo co@(ForAllCo {})       = isEmptyVarSet (tyCoVarsOfCo co)
 noFreeVarsOfCo (FunCo _ c1 c2)        = noFreeVarsOfCo c1 && noFreeVarsOfCo c2
 noFreeVarsOfCo (CoVarCo _)            = False
+noFreeVarsOfCo (HoleCo {})            = True    -- I'm unsure; probably never happens
 noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args
 noFreeVarsOfCo (UnivCo p _ t1 t2)     = noFreeVarsOfProv p &&
                                         noFreeVarsOfType t1 &&
                                         noFreeVarsOfType t2
 noFreeVarsOfCo (SymCo co)             = noFreeVarsOfCo co
 noFreeVarsOfCo (TransCo co1 co2)      = noFreeVarsOfCo co1 && noFreeVarsOfCo co2
-noFreeVarsOfCo (NthCo _ co)           = noFreeVarsOfCo co
+noFreeVarsOfCo (NthCo _ _ co)         = noFreeVarsOfCo co
 noFreeVarsOfCo (LRCo _ co)            = noFreeVarsOfCo co
 noFreeVarsOfCo (InstCo co1 co2)       = noFreeVarsOfCo co1 && noFreeVarsOfCo co2
-noFreeVarsOfCo (CoherenceCo co1 co2)  = noFreeVarsOfCo co1 && noFreeVarsOfCo co2
 noFreeVarsOfCo (KindCo co)            = noFreeVarsOfCo co
 noFreeVarsOfCo (SubCo co)             = noFreeVarsOfCo co
 noFreeVarsOfCo (AxiomRuleCo _ cs)     = all noFreeVarsOfCo cs
@@ -1600,7 +1917,6 @@ noFreeVarsOfProv UnsafeCoerceProv    = True
 noFreeVarsOfProv (PhantomProv co)    = noFreeVarsOfCo co
 noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co
 noFreeVarsOfProv (PluginProv {})     = True
-noFreeVarsOfProv (HoleProv {})       = True -- matches with coVarsOfProv, but I'm unsure
 
 {-
 %************************************************************************
@@ -1628,7 +1944,7 @@ data TCvSubst
   = TCvSubst InScopeSet -- The in-scope type and kind variables
              TvSubstEnv -- Substitutes both type and kind variables
              CvSubstEnv -- Substitutes coercion variables
-        -- See Note [Apply Once]
+        -- See Note [Substitutions apply only once]
         -- and Note [Extending the TvSubstEnv]
         -- and Note [Substituting types and coercions]
         -- and Note [The substitution invariant]
@@ -1636,21 +1952,51 @@ data TCvSubst
 -- | A substitution of 'Type's for 'TyVar's
 --                 and 'Kind's for 'KindVar's
 type TvSubstEnv = TyVarEnv Type
-        -- A TvSubstEnv is used both inside a TCvSubst (with the apply-once
-        -- invariant discussed in Note [Apply Once]), and also independently
-        -- in the middle of matching, and unification (see Types.Unify)
-        -- So you have to look at the context to know if it's idempotent or
-        -- apply-once or whatever
+  -- NB: A TvSubstEnv is used
+  --   both inside a TCvSubst (with the apply-once invariant
+  --        discussed in Note [Substitutions apply only once],
+  --   and  also independently in the middle of matching,
+  --        and unification (see Types.Unify).
+  -- So you have to look at the context to know if it's idempotent or
+  -- apply-once or whatever
 
 -- | A substitution of 'Coercion's for 'CoVar's
 type CvSubstEnv = CoVarEnv Coercion
 
-{-
-Note [Apply Once]
-~~~~~~~~~~~~~~~~~
+{- Note [The substitution invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When calling (substTy subst ty) it should be the case that
+the in-scope set in the substitution is a superset of both:
+
+  (SIa) The free vars of the range of the substitution
+  (SIb) The free vars of ty minus the domain of the substitution
+
+The same rules apply to other substitutions (notably CoreSubst.Subst)
+
+* Reason for (SIa). Consider
+      substTy [a :-> Maybe b] (forall b. b->a)
+  we must rename the forall b, to get
+      forall b2. b2 -> Maybe b
+  Making 'b' part of the in-scope set forces this renaming to
+  take place.
+
+* Reason for (SIb). Consider
+     substTy [a :-> Maybe b] (forall b. (a,b,x))
+  Then if we use the in-scope set {b}, satisfying (SIa), there is
+  a danger we will rename the forall'd variable to 'x' by mistake,
+  getting this:
+      forall x. (Maybe b, x, x)
+  Breaking (SIb) caused the bug from #11371.
+
+Note: if the free vars of the range of the substitution are freshly created,
+then the problems of (SIa) can't happen, and so it would be sound to
+ignore (SIa).
+
+Note [Substitutions apply only once]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We use TCvSubsts to instantiate things, and we might instantiate
         forall a b. ty
-\with the types
+with the types
         [a, b], or [b, a].
 So the substitution might go [a->b, b->a].  A similar situation arises in Core
 when we find a beta redex like
@@ -1658,9 +2004,9 @@ when we find a beta redex like
 Then we also end up with a substitution that permutes type variables. Other
 variations happen to; for example [a -> (a, b)].
 
-        ****************************************************
-        *** So a TCvSubst must be applied precisely once ***
-        ****************************************************
+        ********************************************************
+        *** So a substitution must be applied precisely once ***
+        ********************************************************
 
 A TCvSubst is not idempotent, but, unlike the non-idempotent substitution
 we use during unifications, it must not be repeatedly applied.
@@ -1680,7 +2026,7 @@ nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
 
 This invariant has several crucial consequences:
 
-* In substTyVarBndr, we need extend the TvSubstEnv
+* In substVarBndr, we need extend the TvSubstEnv
         - if the unique has changed
         - or if the kind has changed
 
@@ -1703,25 +2049,6 @@ Note that the TvSubstEnv should *never* map a CoVar (built with the Id
 constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore,
 the range of the TvSubstEnv should *never* include a type headed with
 CoercionTy.
-
-Note [The substitution invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When calling (substTy subst ty) it should be the case that
-the in-scope set in the substitution is a superset of both:
-
-  * The free vars of the range of the substitution
-  * The free vars of ty minus the domain of the substitution
-
-If we want to substitute [a -> ty1, b -> ty2] I used to
-think it was enough to generate an in-scope set that includes
-fv(ty1,ty2).  But that's not enough; we really should also take the
-free vars of the type we are substituting into!  Example:
-     (forall b. (a,b,x)) [a -> List b]
-Then if we use the in-scope set {b}, there is a danger we will rename
-the forall'd variable to 'x' by mistake, getting this:
-     (forall x. (List b, x, x))
-
-Breaking this invariant caused the bug from #11371.
 -}
 
 emptyTvSubstEnv :: TvSubstEnv
@@ -1773,6 +2100,10 @@ mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst
 -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst
 mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv
 
+mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst
+-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst
+mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv
+
 getTvSubstEnv :: TCvSubst -> TvSubstEnv
 getTvSubstEnv (TCvSubst _ env _) = env
 
@@ -1831,14 +2162,20 @@ extendTCvSubst subst v ty
   | otherwise
   = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty)
 
+extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst
+extendTCvSubstWithClone subst tcv
+  | isTyVar tcv = extendTvSubstWithClone subst tcv
+  | otherwise   = extendCvSubstWithClone subst tcv
+
 extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst
 extendTvSubst (TCvSubst in_scope tenv cenv) tv ty
   = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv
 
-extendTvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst
-extendTvSubstBinder subst (Named bndr) ty
-  = extendTvSubst subst (binderVar bndr) ty
-extendTvSubstBinder subst (Anon _)     _
+extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst
+extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty
+  = ASSERT( isTyVar v )
+    extendTvSubstAndInScope subst v ty
+extendTvSubstBinderAndInScope subst (Anon _)     _
   = subst
 
 extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst
@@ -1873,6 +2210,10 @@ extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst
 extendTvSubstList subst tvs tys
   = foldl2 extendTvSubst subst tvs tys
 
+extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst
+extendTCvSubstList subst tvs tys
+  = foldl2 extendTCvSubst subst tvs tys
+
 unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst
 -- Works when the ranges are disjoint
 unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)
@@ -1916,6 +2257,18 @@ zipCvSubst cvs cos
   where
     cenv = zipCoEnv cvs cos
 
+zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst
+zipTCvSubst tcvs tys
+  | debugIsOn
+  , neLength tcvs tys
+  = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst
+  | otherwise
+  = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys))
+  where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst
+        zip_tcvsubst (tv:tvs) (ty:tys) subst
+          = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty)
+        zip_tcvsubst _ _ subst = subst -- empty case
+
 -- | Generates the in-scope set for the 'TCvSubst' from the types in the
 -- incoming environment. No CoVars, please!
 mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst
@@ -2002,13 +2355,42 @@ sym (ForAllCo tv h g)
 ==>
 ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])
 
+Note [Substituting in a coercion hole]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It seems highly suspicious to be substituting in a coercion that still
+has coercion holes. Yet, this can happen in a situation like this:
+
+  f :: forall k. k :~: Type -> ()
+  f Refl = let x :: forall (a :: k). [a] -> ...
+               x = ...
+
+When we check x's type signature, we require that k ~ Type. We indeed
+know this due to the Refl pattern match, but the eager unifier can't
+make use of givens. So, when we're done looking at x's type, a coercion
+hole will remain. Then, when we're checking x's definition, we skolemise
+x's type (in order to, e.g., bring the scoped type variable `a` into scope).
+This requires performing a substitution for the fresh skolem variables.
+
+This subsitution needs to affect the kind of the coercion hole, too --
+otherwise, the kind will have an out-of-scope variable in it. More problematically
+in practice (we won't actually notice the out-of-scope variable ever), skolems
+in the kind might have too high a level, triggering a failure to uphold the
+invariant that no free variables in a type have a higher level than the
+ambient level in the type checker. In the event of having free variables in the
+hole's kind, I'm pretty sure we'll always have an erroneous program, so we
+don't need to worry what will happen when the hole gets filled in. After all,
+a hole relating a locally-bound type variable will be unable to be solved. This
+is why it's OK not to look through the IORef of a coercion hole during
+substitution.
+
 -}
 
 -- | Type substitution, see 'zipTvSubst'
 substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type
 -- Works only if the domain of the substitution is a
 -- superset of the type being substituted into
-substTyWith tvs tys = ASSERT( tvs `equalLength` tys )
+substTyWith tvs tys = {-#SCC "substTyWith" #-}
+                      ASSERT( tvs `equalLength` tys )
                       substTy (zipTvSubst tvs tys)
 
 -- | Type substitution, see 'zipTvSubst'. Disables sanity checks.
@@ -2086,17 +2468,16 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
 -- Note [The substitution invariant].
 checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a
 checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a
-  = ASSERT2( isValidTCvSubst subst,
+-- TODO (RAE): Change back to ASSERT
+  = WARN( not (isValidTCvSubst subst),
              text "in_scope" <+> ppr in_scope $$
              text "tenv" <+> ppr tenv $$
-             text "tenvFVs"
-               <+> ppr (tyCoVarsOfTypesSet tenv) $$
+             text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$
              text "cenv" <+> ppr cenv $$
-             text "cenvFVs"
-               <+> ppr (tyCoVarsOfCosSet cenv) $$
+             text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$
              text "tys" <+> ppr tys $$
              text "cos" <+> ppr cos )
-    ASSERT2( tysCosFVsInScope,
+    WARN( not tysCosFVsInScope,
              text "in_scope" <+> ppr in_scope $$
              text "tenv" <+> ppr tenv $$
              text "cenv" <+> ppr cenv $$
@@ -2181,10 +2562,10 @@ subst_ty subst ty
     go (TyConApp tc tys) = let args = map go tys
                            in  args `seqList` TyConApp tc args
     go (FunTy arg res)   = (FunTy $! go arg) $! go res
-    go (ForAllTy (TvBndr tv vis) ty)
-                         = case substTyVarBndrUnchecked subst tv of
+    go (ForAllTy (Bndr tv vis) ty)
+                         = case substVarBndrUnchecked subst tv of
                              (subst', tv') ->
-                               (ForAllTy $! ((TvBndr $! tv') vis)) $!
+                               (ForAllTy $! ((Bndr $! tv') vis)) $!
                                             (subst_ty subst' ty)
     go (LitTy n)         = LitTy $! n
     go (CastTy ty co)    = (mkCastTy $! (go ty)) $! (subst_co subst co)
@@ -2200,6 +2581,14 @@ substTyVar (TCvSubst _ tenv _) tv
 substTyVars :: TCvSubst -> [TyVar] -> [Type]
 substTyVars subst = map $ substTyVar subst
 
+substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type]
+substTyCoVars subst = map $ substTyCoVar subst
+
+substTyCoVar :: TCvSubst -> TyCoVar -> Type
+substTyCoVar subst tv
+  | isTyVar tv = substTyVar subst tv
+  | otherwise = CoercionTy $ substCoVar subst tv
+
 lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type
         -- See Note [Extending the TCvSubst]
 lookupTyVar (TCvSubst _ tenv _) tv
@@ -2239,14 +2628,20 @@ subst_co subst co
     go_ty :: Type -> Type
     go_ty = subst_ty subst
 
+    go_mco :: MCoercion -> MCoercion
+    go_mco MRefl    = MRefl
+    go_mco (MCo co) = MCo (go co)
+
     go :: Coercion -> Coercion
-    go (Refl r ty)           = mkReflCo r $! go_ty ty
+    go (Refl ty)             = mkNomReflCo $! (go_ty ty)
+    go (GRefl r ty mco)      = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco)
     go (TyConAppCo r tc args)= let args' = map go args
                                in  args' `seqList` mkTyConAppCo r tc args'
     go (AppCo co arg)        = (mkAppCo $! go co) $! go arg
     go (ForAllCo tv kind_co co)
-      = case substForAllCoBndrUnchecked subst tv kind_co of { (subst', tv', kind_co') ->
-          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co }
+      = case substForAllCoBndrUnchecked subst tv kind_co of
+         (subst', tv', kind_co') ->
+          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co
     go (FunCo r co1 co2)     = (mkFunCo r $! go co1) $! go co2
     go (CoVarCo cv)          = substCoVar subst cv
     go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos
@@ -2254,51 +2649,60 @@ subst_co subst co
                                 (go_ty t1)) $! (go_ty t2)
     go (SymCo co)            = mkSymCo $! (go co)
     go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)
-    go (NthCo d co)          = mkNthCo d $! (go co)
+    go (NthCo r d co)        = mkNthCo r d $! (go co)
     go (LRCo lr co)          = mkLRCo lr $! (go co)
     go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg
-    go (CoherenceCo co1 co2) = (mkCoherenceCo $! (go co1)) $! (go co2)
     go (KindCo co)           = mkKindCo $! (go co)
     go (SubCo co)            = mkSubCo $! (go co)
     go (AxiomRuleCo c cs)    = let cs1 = map go cs
                                 in cs1 `seqList` AxiomRuleCo c cs1
+    go (HoleCo h)            = HoleCo $! go_hole h
 
     go_prov UnsafeCoerceProv     = UnsafeCoerceProv
     go_prov (PhantomProv kco)    = PhantomProv (go kco)
     go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)
     go_prov p@(PluginProv _)     = p
-    go_prov p@(HoleProv _)       = p
-      -- NB: this last case is a little suspicious, but we need it. Originally,
-      -- there was a panic here, but it triggered from deeplySkolemise. Because
-      -- we only skolemise tyvars that are manually bound, this operation makes
-      -- sense, even over a coercion with holes.
 
-substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)
+    -- See Note [Substituting in a coercion hole]
+    go_hole h@(CoercionHole { ch_co_var = cv })
+      = h { ch_co_var = updateVarType go_ty cv }
+
+substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion
+                  -> (TCvSubst, TyCoVar, Coercion)
 substForAllCoBndr subst
-  = substForAllCoBndrCallback False (substCo subst) subst
+  = substForAllCoBndrUsing False (substCo subst) subst
 
 -- | Like 'substForAllCoBndr', but disables sanity checks.
 -- The problems that the sanity checks in substCo catch are described in
 -- Note [The substitution invariant].
 -- The goal of #11371 is to migrate all the calls of substCoUnchecked to
 -- substCo and remove this function. Please don't use in new code.
-substForAllCoBndrUnchecked :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion)
+substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion
+                           -> (TCvSubst, TyCoVar, Coercion)
 substForAllCoBndrUnchecked subst
-  = substForAllCoBndrCallback False (substCoUnchecked subst) subst
+  = substForAllCoBndrUsing False (substCoUnchecked subst) subst
 
 -- See Note [Sym and ForAllCo]
-substForAllCoBndrCallback :: Bool  -- apply sym to binder?
-                          -> (Coercion -> Coercion)  -- transformation to kind co
-                          -> TCvSubst -> TyVar -> Coercion
-                          -> (TCvSubst, TyVar, Coercion)
-substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv)
-                          old_var old_kind_co
-  = ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv
+substForAllCoBndrUsing :: Bool  -- apply sym to binder?
+                       -> (Coercion -> Coercion)  -- transformation to kind co
+                       -> TCvSubst -> TyCoVar -> KindCoercion
+                       -> (TCvSubst, TyCoVar, KindCoercion)
+substForAllCoBndrUsing sym sco subst old_var
+  | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var
+  | otherwise       = substForAllCoCoVarBndrUsing sym sco subst old_var
+
+substForAllCoTyVarBndrUsing :: Bool  -- apply sym to binder?
+                            -> (Coercion -> Coercion)  -- transformation to kind co
+                            -> TCvSubst -> TyVar -> KindCoercion
+                            -> (TCvSubst, TyVar, KindCoercion)
+substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co
+  = ASSERT( isTyVar old_var )
+    ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv
     , new_var, new_kind_co )
   where
     new_env | no_change && not sym = delVarEnv tenv old_var
             | sym       = extendVarEnv tenv old_var $
-                            TyVarTy new_var `CastTy` new_kind_co
+                          TyVarTy new_var `CastTy` new_kind_co
             | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
 
     no_kind_change = noFreeVarsOfCo old_kind_co
@@ -2308,9 +2712,38 @@ substForAllCoBndrCallback sym sco (TCvSubst in_scope tenv cenv)
                 | otherwise      = sco old_kind_co
 
     Pair new_ki1 _ = coercionKind new_kind_co
+    -- We could do substitution to (tyVarKind old_var). We don't do so because
+    -- we already substituted new_kind_co, which contains the kind information
+    -- we want. We don't want to do substitution once more. Also, in most cases,
+    -- new_kind_co is a Refl, in which case coercionKind is really fast.
 
     new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)
 
+substForAllCoCoVarBndrUsing :: Bool  -- apply sym to binder?
+                            -> (Coercion -> Coercion)  -- transformation to kind co
+                            -> TCvSubst -> CoVar -> KindCoercion
+                            -> (TCvSubst, CoVar, KindCoercion)
+substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)
+                            old_var old_kind_co
+  = ASSERT( isCoVar old_var )
+    ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv
+    , new_var, new_kind_co )
+  where
+    new_cenv | no_change && not sym = delVarEnv cenv old_var
+             | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)
+
+    no_kind_change = noFreeVarsOfCo old_kind_co
+    no_change = no_kind_change && (new_var == old_var)
+
+    new_kind_co | no_kind_change = old_kind_co
+                | otherwise      = sco old_kind_co
+
+    Pair h1 h2 = coercionKind new_kind_co
+
+    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type
+    new_var_type  | sym       = h2
+                  | otherwise = h1
+
 substCoVar :: TCvSubst -> CoVar -> Coercion
 substCoVar (TCvSubst _ _ cenv) cv
   = case lookupVarEnv cenv cv of
@@ -2320,25 +2753,45 @@ substCoVar (TCvSubst _ _ cenv) cv
 substCoVars :: TCvSubst -> [CoVar] -> [Coercion]
 substCoVars subst cvs = map (substCoVar subst) cvs
 
-lookupCoVar :: TCvSubst -> Var  -> Maybe Coercion
+lookupCoVar :: TCvSubst -> Var -> Maybe Coercion
 lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v
 
 substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
-substTyVarBndr = substTyVarBndrCallback substTy
+substTyVarBndr = substTyVarBndrUsing substTy
+
+substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
+substTyVarBndrs = mapAccumL substTyVarBndr
+
+substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)
+substVarBndr = substVarBndrUsing substTy
+
+substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar])
+substVarBndrs = mapAccumL substVarBndr
 
--- | Like 'substTyVarBndr' but disables sanity checks.
+substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar)
+substCoVarBndr = substCoVarBndrUsing substTy
+
+-- | Like 'substVarBndr', but disables sanity checks.
 -- The problems that the sanity checks in substTy catch are described in
 -- Note [The substitution invariant].
 -- The goal of #11371 is to migrate all the calls of substTyUnchecked to
 -- substTy and remove this function. Please don't use in new code.
-substTyVarBndrUnchecked :: TCvSubst -> TyVar -> (TCvSubst, TyVar)
-substTyVarBndrUnchecked = substTyVarBndrCallback substTyUnchecked
+substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)
+substVarBndrUnchecked = substVarBndrUsing substTyUnchecked
+
+substVarBndrUsing :: (TCvSubst -> Type -> Type)
+                  -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)
+substVarBndrUsing subst_fn subst v
+  | isTyVar v = substTyVarBndrUsing subst_fn subst v
+  | otherwise = substCoVarBndrUsing subst_fn subst v
 
 -- | Substitute a tyvar in a binding position, returning an
 -- extended subst and a new tyvar.
-substTyVarBndrCallback :: (TCvSubst -> Type -> Type)  -- ^ the subst function
-                       -> TCvSubst -> TyVar -> (TCvSubst, TyVar)
-substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
+-- Use the supplied function to substitute in the kind
+substTyVarBndrUsing
+  :: (TCvSubst -> Type -> Type)  -- ^ Use this to substitute in the kind
+  -> TCvSubst -> TyVar -> (TCvSubst, TyVar)
+substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
   = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst )
     ASSERT( isTyVar old_var )
     (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var)
@@ -2367,13 +2820,18 @@ substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
                           setTyVarKind old_var (subst_fn subst old_ki)
         -- The uniqAway part makes sure the new variable is not already in scope
 
-substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar)
-substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var
+-- | Substitute a covar in a binding position, returning an
+-- extended subst and a new covar.
+-- Use the supplied function to substitute in the kind
+substCoVarBndrUsing
+  :: (TCvSubst -> Type -> Type)
+  -> TCvSubst -> CoVar -> (TCvSubst, CoVar)
+substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var
   = ASSERT( isCoVar old_var )
     (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)
   where
     new_co         = mkCoVarCo new_var
-    no_kind_change = all noFreeVarsOfType [t1, t2]
+    no_kind_change = noFreeVarsOfTypes [t1, t2]
     no_change      = new_var == old_var && no_kind_change
 
     new_cenv | no_change = delVarEnv cenv old_var
@@ -2383,8 +2841,8 @@ substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var
     subst_old_var = mkCoVar (varName old_var) new_var_type
 
     (_, _, t1, t2, role) = coVarKindsTypesRole old_var
-    t1' = substTy subst t1
-    t2' = substTy subst t2
+    t1' = subst_fn subst t1
+    t2' = subst_fn subst t2
     new_var_type = mkCoercionType role t1' t2'
                   -- It's important to do the substitution for coercions,
                   -- because they can have free type variables
@@ -2425,17 +2883,28 @@ defined to use this.  @pprParendType@ is the same, except it puts
 parens around the type, except for the atomic cases.  @pprParendType@
 works just by setting the initial context precedence very high.
 
+Note that any function which pretty-prints a @Type@ first converts the @Type@
+to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType.
+
 See Note [Precedence in types] in BasicTypes.
 -}
 
-------------------
+--------------------------------------------------------
+-- When pretty-printing types, we convert to IfaceType,
+--   and pretty-print that.
+-- See Note [Pretty printing via IfaceSyn] in PprTyThing
+--------------------------------------------------------
 
 pprType, pprParendType :: Type -> SDoc
-pprType       = pprPrecType TopPrec
-pprParendType = pprPrecType TyConPrec
+pprType       = pprPrecType topPrec
+pprParendType = pprPrecType appPrec
 
-pprPrecType :: TyPrec -> Type -> SDoc
-pprPrecType prec ty = pprPrecIfaceType prec (tidyToIfaceType ty)
+pprPrecType :: PprPrec -> Type -> SDoc
+pprPrecType prec ty
+  = getPprStyle $ \sty ->
+    if debugStyle sty           -- Use pprDebugType when in
+    then debug_ppr_ty prec ty   -- when in debug-style
+    else pprPrecIfaceType prec (tidyToIfaceTypeSty ty sty)
 
 pprTyLit :: TyLit -> SDoc
 pprTyLit = pprIfaceTyLit . toIfaceTyLit
@@ -2444,6 +2913,12 @@ pprKind, pprParendKind :: Kind -> SDoc
 pprKind       = pprType
 pprParendKind = pprParendType
 
+tidyToIfaceTypeSty :: Type -> PprStyle -> IfaceType
+tidyToIfaceTypeSty ty sty
+  | userStyle sty = tidyToIfaceType ty
+  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty
+     -- in latter case, don't tidy, as we'll be printing uniques.
+
 tidyToIfaceType :: Type -> IfaceType
 -- It's vital to tidy before converting to an IfaceType
 -- or nested binders will become indistinguishable!
@@ -2457,15 +2932,38 @@ tidyToIfaceType ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env ty)
     free_tcvs = tyCoVarsOfTypeWellScoped ty
 
 ------------
+pprCo, pprParendCo :: Coercion -> SDoc
+pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)
+pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)
+
+tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion
+tidyToIfaceCoSty co sty
+  | userStyle sty = tidyToIfaceCo co
+  | otherwise     = toIfaceCoercionX (tyCoVarsOfCo co) co
+     -- in latter case, don't tidy, as we'll be printing uniques.
+
+tidyToIfaceCo :: Coercion -> IfaceCoercion
+-- It's vital to tidy before converting to an IfaceType
+-- or nested binders will become indistinguishable!
+--
+-- Also for the free type variables, tell toIfaceCoercionX to
+-- leave them as IfaceFreeCoVar.  This is super-important
+-- for debug printing.
+tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)
+  where
+    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs
+    free_tcvs = toposortTyVars $ tyCoVarsOfCoList co
+
+------------
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
 
 ------------
 pprTheta :: ThetaType -> SDoc
-pprTheta = pprIfaceContext TopPrec . map tidyToIfaceType
+pprTheta = pprIfaceContext topPrec . map tidyToIfaceType
 
 pprParendTheta :: ThetaType -> SDoc
-pprParendTheta = pprIfaceContext TyConPrec . map tidyToIfaceType
+pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType
 
 pprThetaArrowTy :: ThetaType -> SDoc
 pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType
@@ -2478,22 +2976,21 @@ instance Outputable TyLit where
    ppr = pprTyLit
 
 ------------------
-
 pprSigmaType :: Type -> SDoc
 pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType
 
-pprForAll :: [TyVarBinder] -> SDoc
+pprForAll :: [TyCoVarBinder] -> SDoc
 pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)
 
 -- | Print a user-level forall; see Note [When to print foralls]
-pprUserForAll :: [TyVarBinder] -> SDoc
+pprUserForAll :: [TyCoVarBinder] -> SDoc
 pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr
 
-pprTvBndrs :: [TyVarBinder] -> SDoc
-pprTvBndrs tvs = sep (map pprTvBndr tvs)
+pprTCvBndrs :: [TyCoVarBinder] -> SDoc
+pprTCvBndrs tvs = sep (map pprTCvBndr tvs)
 
-pprTvBndr :: TyVarBinder -> SDoc
-pprTvBndr = pprTyVar . binderVar
+pprTCvBndr :: TyCoVarBinder -> SDoc
+pprTCvBndr = pprTyVar . binderVar
 
 pprTyVars :: [TyVar] -> SDoc
 pprTyVars tvs = sep (map pprTyVar tvs)
@@ -2509,16 +3006,67 @@ pprTyVar tv
   where
     kind = tyVarKind tv
 
-instance Outputable TyBinder where
+instance Outputable TyCoBinder where
   ppr (Anon ty) = text "[anon]" <+> ppr ty
-  ppr (Named (TvBndr v Required))  = ppr v
-  ppr (Named (TvBndr v Specified)) = char '@' <> ppr v
-  ppr (Named (TvBndr v Inferred))  = braces (ppr v)
+  ppr (Named (Bndr v Required))  = ppr v
+  ppr (Named (Bndr v Specified)) = char '@' <> ppr v
+  ppr (Named (Bndr v Inferred))  = braces (ppr v)
 
 -----------------
 instance Outputable Coercion where -- defined here to avoid orphans
   ppr = pprCo
 
+debugPprType :: Type -> SDoc
+-- ^ debugPprType is a simple pretty printer that prints a type
+-- without going through IfaceType.  It does not format as prettily
+-- as the normal route, but it's much more direct, and that can
+-- be useful for debugging.  E.g. with -dppr-debug it prints the
+-- kind on type-variable /occurrences/ which the normal route
+-- fundamentally cannot do.
+debugPprType ty = debug_ppr_ty topPrec ty
+
+debug_ppr_ty :: PprPrec -> Type -> SDoc
+debug_ppr_ty _ (LitTy l)
+  = ppr l
+
+debug_ppr_ty _ (TyVarTy tv)
+  = ppr tv  -- With -dppr-debug we get (tv :: kind)
+
+debug_ppr_ty prec (FunTy arg res)
+  = maybeParen prec funPrec $
+    sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res]
+
+debug_ppr_ty prec (TyConApp tc tys)
+  | null tys  = ppr tc
+  | otherwise = maybeParen prec appPrec $
+                hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))
+
+debug_ppr_ty prec (AppTy t1 t2)
+  = hang (debug_ppr_ty prec t1)
+       2 (debug_ppr_ty appPrec t2)
+
+debug_ppr_ty prec (CastTy ty co)
+  = maybeParen prec topPrec $
+    hang (debug_ppr_ty topPrec ty)
+       2 (text "|>" <+> ppr co)
+
+debug_ppr_ty _ (CoercionTy co)
+  = parens (text "CO" <+> ppr co)
+
+debug_ppr_ty prec ty@(ForAllTy {})
+  | (tvs, body) <- split ty
+  = maybeParen prec funPrec $
+    hang (text "forall" <+> fsep (map ppr tvs) <> dot)
+         -- The (map ppr tvs) will print kind-annotated
+         -- tvs, because we are (usually) in debug-style
+       2 (ppr body)
+  where
+    split ty | ForAllTy tv ty' <- ty
+             , (tvs, body) <- split ty'
+             = (tv:tvs, body)
+             | otherwise
+             = ([], ty)
+
 {-
 Note [When to print foralls]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2536,7 +3084,7 @@ This catches common situations, such as a type siguature
 which means
       f :: forall k. forall (m :: k->*) (a :: k). m a
 We really want to see both the "forall k" and the kind signatures
-on m and a.  The latter comes from pprTvBndr.
+on m and a.  The latter comes from pprTCvBndr.
 
 Note [Infix type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2566,37 +3114,20 @@ pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
 pprDataConWithArgs :: DataCon -> SDoc
 pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
   where
-    (_univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
-    univ_bndrs = dataConUnivTyVarBinders dc
-    ex_bndrs   = dataConExTyVarBinders dc
-    forAllDoc = pprUserForAll $ (filterEqSpec eq_spec univ_bndrs ++ ex_bndrs)
-    thetaDoc  = pprThetaArrowTy theta
-    argsDoc   = hsep (fmap pprParendType arg_tys)
+    (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
+    user_bndrs = dataConUserTyVarBinders dc
+    forAllDoc  = pprUserForAll user_bndrs
+    thetaDoc   = pprThetaArrowTy theta
+    argsDoc    = hsep (fmap pprParendType arg_tys)
 
 
 pprTypeApp :: TyCon -> [Type] -> SDoc
 pprTypeApp tc tys
-  = pprIfaceTypeApp TopPrec (toIfaceTyCon tc)
+  = pprIfaceTypeApp topPrec (toIfaceTyCon tc)
                             (toIfaceTcArgs tc tys)
     -- TODO: toIfaceTcArgs seems rather wasteful here
 
-pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc)
-           -> TyCon -> [Coercion] -> SDoc
-pprTcAppCo p _pp tc cos
-  = pprIfaceCoTcApp p (toIfaceTyCon tc) (map toIfaceCoercion cos)
-
 ------------------
-
-pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
-pprPrefixApp = pprIfacePrefixApp
-
-----------------
-pprArrowChain :: TyPrec -> [SDoc] -> SDoc
--- pprArrowChain p [a,b,c]  generates   a -> b -> c
-pprArrowChain _ []         = empty
-pprArrowChain p (arg:args) = maybeParen p FunPrec $
-                             sep [arg, sep (map (arrow <+>) args)]
-
 ppSuggestExplicitKinds :: SDoc
 -- Print a helpful suggstion about -fprint-explicit-kinds,
 -- if it is not already on
@@ -2617,32 +3148,32 @@ ppSuggestExplicitKinds
 -- an interface file.
 --
 -- It doesn't change the uniques at all, just the print names.
-tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
-tidyTyCoVarBndrs (occ_env, subst) tvs
-    = mapAccumL tidyTyCoVarBndr tidy_env' tvs
+tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
+tidyVarBndrs (occ_env, subst) tvs
+    = mapAccumL tidyVarBndr tidy_env' tvs
   where
     -- Seed the occ_env with clashes among the names, see
     -- Node [Tidying multiple names at once] in OccName
-    -- Se still go through tidyTyCoVarBndr so that each kind variable is tidied
+    -- Se still go through tidyVarBndr so that each kind variable is tidied
     -- with the correct tidy_env
     occs = map getHelpfulOccName tvs
     tidy_env' = (avoidClashesOccEnv occ_env occs, subst)
 
-tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
-tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar
-  = case tidyOccName occ_env (getHelpfulOccName tyvar) of
-      (occ_env', occ') -> ((occ_env', subst'), tyvar')
+tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
+tidyVarBndr tidy_env@(occ_env, subst) var
+  = case tidyOccName occ_env (getHelpfulOccName var) of
+      (occ_env', occ') -> ((occ_env', subst'), var')
         where
-          subst' = extendVarEnv subst tyvar tyvar'
-          tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
-          kind'  = tidyKind tidy_env (tyVarKind tyvar)
+          subst' = extendVarEnv subst var var'
+          var'   = setVarType (setVarName var name') type'
+          type'  = tidyType tidy_env (varType var)
           name'  = tidyNameOcc name occ'
-          name   = tyVarName tyvar
+          name   = varName var
 
 getHelpfulOccName :: TyCoVar -> OccName
-getHelpfulOccName tyvar = occ1
+getHelpfulOccName var = occ1
   where
-    name = tyVarName tyvar
+    name = varName var
     occ  = getOccName name
     -- A TcTyVar with a System Name is probably a unification variable;
     -- when we tidy them we give them a trailing "0" (or 1 etc)
@@ -2650,21 +3181,21 @@ getHelpfulOccName tyvar = occ1
     -- Plus, indicating a unification variable in this way is a
     -- helpful clue for users
     occ1 | isSystemName name
-         , isTcTyVar tyvar
+         , isTcTyVar var
          = mkTyVarOcc (occNameString occ ++ "0")
          | otherwise
          = occ
 
-tidyTyVarBinder :: TidyEnv -> TyVarBndr TyVar vis
-                -> (TidyEnv, TyVarBndr TyVar vis)
-tidyTyVarBinder tidy_env (TvBndr tv vis)
-  = (tidy_env', TvBndr tv' vis)
+tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis
+                  -> (TidyEnv, VarBndr TyCoVar vis)
+tidyTyCoVarBinder tidy_env (Bndr tv vis)
+  = (tidy_env', Bndr tv' vis)
   where
-    (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv
+    (tidy_env', tv') = tidyVarBndr tidy_env tv
 
-tidyTyVarBinders :: TidyEnv -> [TyVarBndr TyVar vis]
-                 -> (TidyEnv, [TyVarBndr TyVar vis])
-tidyTyVarBinders = mapAccumL tidyTyVarBinder
+tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]
+                   -> (TidyEnv, [VarBndr TyCoVar vis])
+tidyTyCoVarBinders = mapAccumL tidyTyCoVarBinder
 
 ---------------
 tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv
@@ -2673,7 +3204,7 @@ tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv
 tidyFreeTyCoVars (full_occ_env, var_env) tyvars
   = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars)
 
-        ---------------
+---------------
 tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
 tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars
 
@@ -2681,19 +3212,19 @@ tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars
 tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
 -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name
 -- using the environment if one has not already been allocated. See
--- also 'tidyTyCoVarBndr'
+-- also 'tidyVarBndr'
 tidyOpenTyCoVar env@(_, subst) tyvar
   = case lookupVarEnv subst tyvar of
         Just tyvar' -> (env, tyvar')              -- Already substituted
         Nothing     ->
           let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))
-          in tidyTyCoVarBndr env' tyvar  -- Treat it as a binder
+          in tidyVarBndr env' tyvar  -- Treat it as a binder
 
 ---------------
-tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar
-tidyTyVarOcc env@(_, subst) tv
+tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar
+tidyTyCoVarOcc env@(_, subst) tv
   = case lookupVarEnv subst tv of
-        Nothing  -> updateTyVarKind (tidyType env) tv
+        Nothing  -> updateVarType (tidyType env) tv
         Just tv' -> tv'
 
 ---------------
@@ -2703,7 +3234,7 @@ tidyTypes env tys = map (tidyType env) tys
 ---------------
 tidyType :: TidyEnv -> Type -> Type
 tidyType _   (LitTy n)            = LitTy n
-tidyType env (TyVarTy tv)         = TyVarTy (tidyTyVarOcc env tv)
+tidyType env (TyVarTy tv)         = TyVarTy (tidyTyCoVarOcc env tv)
 tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys
                                     in args `seqList` TyConApp tycon args
 tidyType env (AppTy fun arg)      = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
@@ -2711,7 +3242,7 @@ tidyType env (FunTy fun arg)      = (FunTy $! (tidyType env fun)) $! (tidyType e
 tidyType env (ty@(ForAllTy{}))    = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty
   where
     (tvs, vis, body_ty) = splitForAllTys' ty
-    (env', tvs') = tidyTyCoVarBndrs env tvs
+    (env', tvs') = tidyVarBndrs env tvs
 tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)
 tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)
 
@@ -2719,16 +3250,16 @@ tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)
 -- The following two functions differ from mkForAllTys and splitForAllTys in that
 -- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but
 -- how should they be named?
-mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type
+mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type
 mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs
   where
-    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty
+    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty
 
-splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type)
+splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type)
 splitForAllTys' ty = go ty [] []
   where
-    go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
-    go ty                            tvs viss = (reverse tvs, reverse viss, ty)
+    go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
+    go ty                          tvs viss = (reverse tvs, reverse viss, ty)
 
 
 ---------------
@@ -2767,28 +3298,32 @@ tidyCo :: TidyEnv -> Coercion -> Coercion
 tidyCo env@(_, subst) co
   = go co
   where
-    go (Refl r ty)           = Refl r (tidyType env ty)
+    go_mco MRefl    = MRefl
+    go_mco (MCo co) = MCo (go co)
+
+    go (Refl ty)             = Refl (tidyType env ty)
+    go (GRefl r ty mco)      = GRefl r (tidyType env ty) $! go_mco mco
     go (TyConAppCo r tc cos) = let args = map go cos
                                in args `seqList` TyConAppCo r tc args
     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2
     go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)
-                               where (envp, tvp) = tidyTyCoVarBndr env tv
+                               where (envp, tvp) = tidyVarBndr env tv
             -- the case above duplicates a bit of work in tidying h and the kind
             -- of tv. But the alternative is to use coercionKind, which seems worse.
     go (FunCo r co1 co2)     = (FunCo r $! go co1) $! go co2
     go (CoVarCo cv)          = case lookupVarEnv subst cv of
                                  Nothing  -> CoVarCo cv
                                  Just cv' -> CoVarCo cv'
+    go (HoleCo h)            = HoleCo h
     go (AxiomInstCo con ind cos) = let args = map go cos
                                in  args `seqList` AxiomInstCo con ind args
     go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!
                                 tidyType env t1) $! tidyType env t2
     go (SymCo co)            = SymCo $! go co
     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
-    go (NthCo d co)          = NthCo d $! go co
+    go (NthCo r d co)        = NthCo r d $! go co
     go (LRCo lr co)          = LRCo lr $! go co
     go (InstCo co ty)        = (InstCo $! go co) $! go ty
-    go (CoherenceCo co1 co2) = (CoherenceCo $! go co1) $! go co2
     go (KindCo co)           = KindCo $! go co
     go (SubCo co)            = SubCo $! go co
     go (AxiomRuleCo ax cos)  = let cos1 = tidyCos env cos
@@ -2798,7 +3333,6 @@ tidyCo env@(_, subst) co
     go_prov (PhantomProv co)    = PhantomProv (go co)
     go_prov (ProofIrrelProv co) = ProofIrrelProv (go co)
     go_prov p@(PluginProv _)    = p
-    go_prov p@(HoleProv _)      = p
 
 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
 tidyCos env = map (tidyCo env)
@@ -2828,26 +3362,28 @@ typeSize (LitTy {})                 = 1
 typeSize (TyVarTy {})               = 1
 typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2
 typeSize (FunTy t1 t2)              = typeSize t1 + typeSize t2
-typeSize (ForAllTy (TvBndr tv _) t) = typeSize (tyVarKind tv) + typeSize t
+typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t
 typeSize (TyConApp _ ts)            = 1 + sum (map typeSize ts)
 typeSize (CastTy ty co)             = typeSize ty + coercionSize co
 typeSize (CoercionTy co)            = coercionSize co
 
 coercionSize :: Coercion -> Int
-coercionSize (Refl _ ty)         = typeSize ty
+coercionSize (Refl ty)             = typeSize ty
+coercionSize (GRefl _ ty MRefl)    = typeSize ty
+coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co
 coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)
 coercionSize (AppCo co arg)      = coercionSize co + coercionSize arg
 coercionSize (ForAllCo _ h co)   = 1 + coercionSize co + coercionSize h
 coercionSize (FunCo _ co1 co2)   = 1 + coercionSize co1 + coercionSize co2
 coercionSize (CoVarCo _)         = 1
+coercionSize (HoleCo _)          = 1
 coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args)
 coercionSize (UnivCo p _ t1 t2)  = 1 + provSize p + typeSize t1 + typeSize t2
 coercionSize (SymCo co)          = 1 + coercionSize co
 coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2
-coercionSize (NthCo _ co)        = 1 + coercionSize co
+coercionSize (NthCo _ _ co)      = 1 + coercionSize co
 coercionSize (LRCo  _ co)        = 1 + coercionSize co
 coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg
-coercionSize (CoherenceCo c1 c2) = 1 + coercionSize c1 + coercionSize c2
 coercionSize (KindCo co)         = 1 + coercionSize co
 coercionSize (SubCo co)          = 1 + coercionSize co
 coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)
@@ -2857,4 +3393,3 @@ provSize UnsafeCoerceProv    = 1
 provSize (PhantomProv co)    = 1 + coercionSize co
 provSize (ProofIrrelProv co) = 1 + coercionSize co
 provSize (PluginProv _)      = 1
-provSize (HoleProv h)        = pprPanic "provSize hits a hole" (ppr h)
diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot
index 8dcbd10744..5af8c1d57f 100644
--- a/compiler/types/TyCoRep.hs-boot
+++ b/compiler/types/TyCoRep.hs-boot
@@ -1,5 +1,7 @@
 module TyCoRep where
 
+import GhcPrelude
+
 import Outputable ( SDoc )
 import Data.Data  ( Data )
 
@@ -9,15 +11,19 @@ data Coercion
 data UnivCoProvenance
 data TCvSubst
 data TyLit
-data TyBinder
+data TyCoBinder
+data MCoercion
 
 type PredType = Type
 type Kind = Type
 type ThetaType = [PredType]
+type CoercionN = Coercion
+type MCoercionN = MCoercion
 
 pprKind :: Kind -> SDoc
 pprType :: Type -> SDoc
 
+isRuntimeRepTy :: Type -> Bool
+
 instance Data Type
   -- To support Data instances in CoAxiom
-
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 1be318d96a..0bbd8c9e0e 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -10,16 +10,17 @@ The @TyCon@ datatype
 
 module TyCon(
         -- * Main TyCon data types
-        TyCon, AlgTyConRhs(..), visibleDataCons,
+        TyCon,
+        AlgTyConRhs(..), visibleDataCons,
         AlgTyConFlav(..), isNoParent,
         FamTyConFlav(..), Role(..), Injectivity(..),
         RuntimeRepInfo(..), TyConFlavour(..),
 
         -- * TyConBinder
-        TyConBinder, TyConBndrVis(..),
+        TyConBinder, TyConBndrVis(..), TyConTyCoBinder,
         mkNamedTyConBinder, mkNamedTyConBinders,
         mkAnonTyConBinder, mkAnonTyConBinders,
-        tyConBinderArgFlag, isNamedTyConBinder,
+        tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder,
         isVisibleTyConBinder, isInvisibleTyConBinder,
 
         -- ** Field labels
@@ -34,6 +35,7 @@ module TyCon(
         mkLiftedPrimTyCon,
         mkTupleTyCon,
         mkSumTyCon,
+        mkDataTyConRhs,
         mkSynonymTyCon,
         mkFamilyTyCon,
         mkPromotedDataCon,
@@ -59,7 +61,7 @@ module TyCon(
         isFamilyTyCon, isOpenFamilyTyCon,
         isTypeFamilyTyCon, isDataFamilyTyCon,
         isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,
-        familyTyConInjectivityInfo,
+        tyConInjectivityInfo,
         isBuiltInSynFamTyCon_maybe,
         isUnliftedTyCon,
         isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,
@@ -73,7 +75,7 @@ module TyCon(
         tyConSkolem,
         tyConKind,
         tyConUnique,
-        tyConTyVars,
+        tyConTyVars, tyConVisibleTyVars,
         tyConCType, tyConCType_maybe,
         tyConDataCons, tyConDataCons_maybe,
         tyConSingleDataCon_maybe, tyConSingleDataCon,
@@ -94,8 +96,9 @@ module TyCon(
         newTyConDataCon_maybe,
         algTcFields,
         tyConRuntimeRepInfo,
-        tyConBinders, tyConResKind,
-        tcTyConScopedTyVars,
+        tyConBinders, tyConResKind, tyConTyVarBinders,
+        tcTyConScopedTyVars, tcTyConUserTyVars,
+        mkTyConTagMap,
 
         -- ** Manipulating TyCons
         expandSynTyCon_maybe,
@@ -114,22 +117,26 @@ module TyCon(
         -- * Primitive representations of Types
         PrimRep(..), PrimElemRep(..),
         isVoidRep, isGcPtrRep,
-        primRepSizeW, primElemRepSizeB,
+        primRepSizeB,
+        primElemRepSizeB,
         primRepIsFloat,
 
         -- * Recursion breaking
-        RecTcChecker, initRecTc, checkRecTc
+        RecTcChecker, initRecTc, defaultRecTcMaxBound,
+        setRecTcMaxBound, checkRecTc
 
 ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} TyCoRep    ( Kind, Type, PredType, pprType )
 import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind
                                  , vecCountTyCon, vecElemTyCon, liftedTypeKind
                                  , mkFunKind, mkForAllKind )
-import {-# SOURCE #-} DataCon    ( DataCon, dataConExTyVars, dataConFieldLabels
-                                 , dataConTyCon )
+import {-# SOURCE #-} DataCon    ( DataCon, dataConExTyCoVars, dataConFieldLabels
+                                 , dataConTyCon, dataConFullSig )
 
 import Binary
 import Var
@@ -147,9 +154,10 @@ import FastStringEnv
 import FieldLabel
 import Constants
 import Util
-import Unique( tyConRepNameUnique, dataConRepNameUnique )
+import Unique( tyConRepNameUnique, dataConTyRepNameUnique )
 import UniqSet
 import Module
+import {-# SOURCE #-} DataCon
 
 import qualified Data.Data as Data
 
@@ -222,7 +230,10 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
         DataFamInstTyCon T [Int] ax_ti
 
 * The axiom ax_ti may be eta-reduced; see
-  Note [Eta reduction for data family axioms] in TcInstDcls
+  Note [Eta reduction for data family axioms] in FamInstEnv
+
+* Data family instances may have a different arity than the data family.
+  See Note [Arity of data families] in FamInstEnv
 
 * The data constructor T2 has a wrapper (which is what the
   source-level "T2" invokes):
@@ -238,7 +249,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
 
   Here's the FC version of the above declaration:
 
-        data R:TPair a where
+        data R:TPair a b where
           X1 :: R:TPair Int Bool
           X2 :: a -> b -> R:TPair a b
         axiom ax_pr :: T (a,b)  ~R  R:TPair a b
@@ -256,7 +267,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs
         DataFamInstTyCon T [(a,b)] ax_pr
 
 * Notice that T is NOT translated to a FC type function; it just
-  becomes a "data type" with no constructors, which can be coerced inot
+  becomes a "data type" with no constructors, which can be coerced
   into R:TInt, R:TPair by the axioms.  These axioms
   axioms come into play when (and *only* when) you
         - use a data constructor
@@ -302,7 +313,7 @@ parent class.
 
 However there is an important sharing relationship between
   * the tyConTyVars of the parent Class
-  * the tyConTyvars of the associated TyCon
+  * the tyConTyVars of the associated TyCon
 
    class C a b where
      data T p a
@@ -376,48 +387,64 @@ See also:
 
 ************************************************************************
 *                                                                      *
-                    TyConBinder
+                    TyConBinder, TyConTyCoBinder
 *                                                                      *
 ************************************************************************
 -}
 
-type TyConBinder = TyVarBndr TyVar TyConBndrVis
+type TyConBinder = VarBndr TyVar TyConBndrVis
+
+-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really
+-- contain CoVar.
+type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis
 
 data TyConBndrVis
   = NamedTCB ArgFlag
   | AnonTCB
 
+instance Outputable TyConBndrVis where
+  ppr (NamedTCB flag) = text "NamedTCB" <+> ppr flag
+  ppr AnonTCB         = text "AnonTCB"
+
 mkAnonTyConBinder :: TyVar -> TyConBinder
-mkAnonTyConBinder tv = TvBndr tv AnonTCB
+mkAnonTyConBinder tv = ASSERT( isTyVar tv)
+                       Bndr tv AnonTCB
 
 mkAnonTyConBinders :: [TyVar] -> [TyConBinder]
 mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs
 
 mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder
 -- The odd argument order supports currying
-mkNamedTyConBinder vis tv = TvBndr tv (NamedTCB vis)
+mkNamedTyConBinder vis tv = ASSERT( isTyVar tv )
+                            Bndr tv (NamedTCB vis)
 
 mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder]
 -- The odd argument order supports currying
 mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs
 
 tyConBinderArgFlag :: TyConBinder -> ArgFlag
-tyConBinderArgFlag (TvBndr _ (NamedTCB vis)) = vis
-tyConBinderArgFlag (TvBndr _ AnonTCB)        = Required
+tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis
+
+tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag
+tyConBndrVisArgFlag (NamedTCB vis) = vis
+tyConBndrVisArgFlag AnonTCB        = Required
 
 isNamedTyConBinder :: TyConBinder -> Bool
 -- Identifies kind variables
 -- E.g. data T k (a:k) = blah
 -- Here 'k' is a NamedTCB, a variable used in the kind of other binders
-isNamedTyConBinder (TvBndr _ (NamedTCB {})) = True
-isNamedTyConBinder _                        = False
+isNamedTyConBinder (Bndr _ (NamedTCB {})) = True
+isNamedTyConBinder _                      = False
 
-isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool
+isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool
 -- Works for IfaceTyConBinder too
-isVisibleTyConBinder (TvBndr _ (NamedTCB vis)) = isVisibleArgFlag vis
-isVisibleTyConBinder (TvBndr _ AnonTCB)        = True
+isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis
+
+isVisibleTcbVis :: TyConBndrVis -> Bool
+isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis
+isVisibleTcbVis AnonTCB        = True
 
-isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool
+isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool
 -- Works for IfaceTyConBinder too
 isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)
 
@@ -425,41 +452,116 @@ mkTyConKind :: [TyConBinder] -> Kind -> Kind
 mkTyConKind bndrs res_kind = foldr mk res_kind bndrs
   where
     mk :: TyConBinder -> Kind -> Kind
-    mk (TvBndr tv AnonTCB)        k = mkFunKind (tyVarKind tv) k
-    mk (TvBndr tv (NamedTCB vis)) k = mkForAllKind tv vis k
+    mk (Bndr tv AnonTCB)        k = mkFunKind (varType tv) k
+    mk (Bndr tv (NamedTCB vis)) k = mkForAllKind tv vis k
+
+tyConTyVarBinders :: [TyConBinder]   -- From the TyCon
+                  -> [TyVarBinder]   -- Suitable for the foralls of a term function
+-- See Note [Building TyVarBinders from TyConBinders]
+tyConTyVarBinders tc_bndrs
+ = map mk_binder tc_bndrs
+ where
+   mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv
+      where
+        vis = case tc_vis of
+                AnonTCB           -> Specified
+                NamedTCB Required -> Specified
+                NamedTCB vis      -> vis
+
+-- Returns only tyvars, as covars are always inferred
+tyConVisibleTyVars :: TyCon -> [TyVar]
+tyConVisibleTyVars tc
+  = [ tv | Bndr tv vis <- tyConBinders tc
+         , isVisibleTcbVis vis ]
+
+{- Note [Building TyVarBinders from TyConBinders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We sometimes need to build the quantified type of a value from
+the TyConBinders of a type or class.  For that we need not
+TyConBinders but TyVarBinders (used in forall-type)  E.g:
+
+ *  From   data T a = MkT (Maybe a)
+    we are going to make a data constructor with type
+           MkT :: forall a. Maybe a -> T a
+    See the TyCoVarBinders passed to buildDataCon
+
+ * From    class C a where { op :: a -> Maybe a }
+   we are going to make a default method
+           $dmop :: forall a. C a => a -> Maybe a
+   See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType
+
+Both of these are user-callable.  (NB: default methods are not callable
+directly by the user but rather via the code generated by 'deriving',
+which uses visible type application; see mkDefMethBind.)
+
+Since they are user-callable we must get their type-argument visibility
+information right; and that info is in the TyConBinders.
+Here is an example:
+
+  data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
+
+The TyCon has
+
+  tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ]
+
+The TyConBinders for App line up with App's kind, given above.
+
+But the DataCon MkApp has the type
+  MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
+
+That is, its TyCoVarBinders should be
+
+  dataConUnivTyVarBinders = [ Bndr (k:*)    Inferred
+                            , Bndr (a:k->*) Specified
+                            , Bndr (b:k)    Specified ]
+
+So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:
+  - variable names from the TyConBinders
+  - but changing Anon/Required to Specified
+
+The last part about Required->Specified comes from this:
+  data T k (a:k) b = MkT (a b)
+Here k is Required in T's kind, but we don't have Required binders in
+the TyCoBinders for a term (see Note [No Required TyCoBinder in terms]
+in TyCoRep), so we change it to Specified when making MkT's TyCoBinders
+-}
+
 
 {- Note [The binders/kind/arity fields of a TyCon]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 All TyCons have this group of fields
-  tyConBinders :: [TyConBinder]
-  tyConResKind :: Kind
-  tyConTyVars  :: [TyVar] -- Cached = binderVars tyConBinders
-  tyConKind    :: Kind    -- Cached = mkTyConKind tyConBinders tyConResKind
-  tyConArity   :: Arity   -- Cached = length tyConBinders
+  tyConBinders   :: [TyConBinder/TyConTyCoBinder]
+  tyConResKind   :: Kind
+  tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders
+                              --   NB: Currently (Aug 2018), TyCons that own this
+                              --   field really only contain TyVars. So it is
+                              --   [TyVar] instead of [TyCoVar].
+  tyConKind      :: Kind      -- Cached = mkTyConKind tyConBinders tyConResKind
+  tyConArity     :: Arity     -- Cached = length tyConBinders
 
 They fit together like so:
 
-* tyConBinders gives the telescope of type variables on the LHS of the
+* tyConBinders gives the telescope of type/coercion variables on the LHS of the
   type declaration.  For example:
 
     type App a (b :: k) = a b
 
-  tyConBinders = [ TvBndr (k::*)   (NamedTCB Inferred)
-                 , TvBndr (a:k->*) AnonTCB
-                 , TvBndr (b:k)    AnonTCB ]
+  tyConBinders = [ Bndr (k::*)   (NamedTCB Inferred)
+                 , Bndr (a:k->*) AnonTCB
+                 , Bndr (b:k)    AnonTCB ]
 
   Note that that are three binders here, including the
   kind variable k.
 
-  See Note [TyBinders and ArgFlags] in TyCoRep for what
-  the visibility flag means.
+- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep
+  for what the visibility flag means.
 
-* Each TyConBinder tyConBinders has a TyVar, and that TyVar may
-  scope over some other part of the TyCon's definition. Eg
-      type T a = a->a
+* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and
+  that TyVar may scope over some other part of the TyCon's definition. Eg
+      type T a = a -> a
   we have
-      tyConBinders = [ TvBndr (a:*) AnonTCB ]
-      synTcRhs     = a->a
+      tyConBinders = [ Bndr (a:*) AnonTCB ]
+      synTcRhs     = a -> a
   So the 'a' scopes over the synTcRhs
 
 * From the tyConBinders and tyConResKind we can get the tyConKind
@@ -477,11 +579,11 @@ They fit together like so:
   So it's just (length tyConBinders)
 -}
 
-instance Outputable tv => Outputable (TyVarBndr tv TyConBndrVis) where
-  ppr (TvBndr v AnonTCB)              = ppr v
-  ppr (TvBndr v (NamedTCB Required))  = ppr v
-  ppr (TvBndr v (NamedTCB Specified)) = char '@' <> ppr v
-  ppr (TvBndr v (NamedTCB Inferred))  = braces (ppr v)
+instance Outputable tv => Outputable (VarBndr tv TyConBndrVis) where
+  ppr (Bndr v AnonTCB)              = text "anon" <+> parens (ppr v)
+  ppr (Bndr v (NamedTCB Required))  = text "req"  <+> parens (ppr v)
+  ppr (Bndr v (NamedTCB Specified)) = text "spec" <+> parens (ppr v)
+  ppr (Bndr v (NamedTCB Inferred))  = text "inf"  <+> parens (ppr v)
 
 instance Binary TyConBndrVis where
   put_ bh AnonTCB        = putByte bh 0
@@ -710,7 +812,7 @@ data TyCon
         tyConName    :: Name,       -- ^ Same Name as the data constructor
 
         -- See Note [The binders/kind/arity fields of a TyCon]
-        tyConBinders :: [TyConBinder], -- ^ Full binders
+        tyConBinders :: [TyConTyCoBinder], -- ^ Full binders
         tyConResKind :: Kind,             -- ^ Result kind
         tyConKind    :: Kind,             -- ^ Kind of this TyCon
         tyConArity   :: Arity,            -- ^ Arity
@@ -721,7 +823,8 @@ data TyCon
         promDcRepInfo :: RuntimeRepInfo  -- ^ See comments with 'RuntimeRepInfo'
     }
 
-  -- | These exist only during a recursive type/class type-checking knot.
+  -- | These exist only during type-checking. See Note [How TcTyCons work]
+  -- in TcTyClsDecls
   | TcTyCon {
         tyConUnique :: Unique,
         tyConName   :: Name,
@@ -733,8 +836,12 @@ data TyCon
         tyConKind    :: Kind,             -- ^ Kind of this TyCon
         tyConArity   :: Arity,            -- ^ Arity
 
-        tcTyConScopedTyVars :: [TyVar], -- ^ Scoped tyvars over the
-                                        -- tycon's body. See Note [TcTyCon]
+        tcTyConScopedTyVars :: [(Name,TyVar)],
+                           -- ^ Scoped tyvars over the tycon's body
+                           -- See Note [How TcTyCons work] in TcTyClsDecls
+                           -- Order does *not* matter.
+        tcTyConUserTyVars :: SDoc, -- ^ Original, user-written tycon tyvars
+
         tcTyConFlavour :: TyConFlavour
                            -- ^ What sort of 'TyCon' this represents.
       }
@@ -756,8 +863,9 @@ data AlgTyConRhs
                           --   user declares the type to have no constructors
                           --
                           -- INVARIANT: Kept in order of increasing 'DataCon'
-                          -- tag (see the tag assignment in DataCon.mkDataCon)
-
+                          -- tag (see the tag assignment in mkTyConTagMap)
+        data_cons_size :: Int,
+                          -- ^ Cached value: length data_cons
         is_enum :: Bool   -- ^ Cached value: is this an enumeration type?
                           --   See Note [Enumeration types]
     }
@@ -768,8 +876,10 @@ data AlgTyConRhs
                                    -- tuple?
     }
 
+  -- | An unboxed sum type.
   | SumTyCon {
-        data_cons :: [DataCon]
+        data_cons :: [DataCon],
+        data_cons_size :: Int  -- ^ Cached value: length data_cons
     }
 
   -- | Information about those 'TyCon's derived from a @newtype@ declaration
@@ -803,6 +913,23 @@ data AlgTyConRhs
                              -- again check Trac #1072.
     }
 
+mkSumTyConRhs :: [DataCon] -> AlgTyConRhs
+mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons)
+
+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
+mkDataTyConRhs cons
+  = DataTyCon {
+        data_cons = cons,
+        data_cons_size = length cons,
+        is_enum = not (null cons) && all is_enum_con cons
+                  -- See Note [Enumeration types] in TyCon
+    }
+  where
+    is_enum_con con
+       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
+           <- dataConFullSig con
+       = null ex_tvs && null eq_spec && null theta && null arg_tys
+
 -- | Some promoted datacons signify extra info relevant to GHC. For example,
 -- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'
 -- constructor of 'PrimRep'. This data structure allows us to store this
@@ -874,7 +1001,8 @@ data AlgTyConFlav
           -- use the tyConTyVars of this TyCon
         TyCon   -- The family TyCon
         [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
-                -- Match in length the tyConTyVars of the family TyCon
+                -- No shorter in length than the tyConTyVars of the family TyCon
+                -- How could it be longer? See [Arity of data families] in FamInstEnv
 
         -- E.g.  data instance T [a] = ...
         -- gives a representation tycon:
@@ -895,7 +1023,7 @@ okParent :: Name -> AlgTyConFlav -> Bool
 okParent _       (VanillaAlgTyCon {})            = True
 okParent _       (UnboxedAlgTyCon {})            = True
 okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)
-okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthIs` tyConArity fam_tc
+okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc
 
 isNoParent :: AlgTyConFlav -> Bool
 isNoParent (VanillaAlgTyCon {}) = True
@@ -1054,51 +1182,8 @@ so the coercion tycon CoT must have
         kind:    T ~ []
  and    arity:   0
 
-Note [TcTyCon]
-~~~~~~~~~~~~~~
-TcTyCons are used for two distinct purposes
-
-1.  When recovering from a type error in a type declaration,
-    we want to put the erroneous TyCon in the environment in a
-    way that won't lead to more errors.  We use a TcTyCon for this;
-    see makeRecoveryTyCon.
-
-2.  When checking a type/class declaration (in module TcTyClsDecls), we come
-    upon knowledge of the eventual tycon in bits and pieces. First, we use
-    getInitialKinds to look over the user-provided kind signature of a tycon
-    (including, for example, the number of parameters written to the tycon)
-    to get an initial shape of the tycon's kind. Then, using these initial
-    kinds, we kind-check the body of the tycon (class methods, data constructors,
-    etc.), filling in the metavariables in the tycon's initial kind.
-    We then generalize to get the tycon's final, fixed kind. Finally, once
-    this has happened for all tycons in a mutually recursive group, we
-    can desugar the lot.
-
-    For convenience, we store partially-known tycons in TcTyCons, which
-    might store meta-variables. These TcTyCons are stored in the local
-    environment in TcTyClsDecls, until the real full TyCons can be created
-    during desugaring. A desugared program should never have a TcTyCon.
-
-    A challenging piece in all of this is that we end up taking three separate
-    passes over every declaration: one in getInitialKind (this pass look only
-    at the head, not the body), one in kcTyClDecls (to kind-check the body),
-    and a final one in tcTyClDecls (to desugar). In the latter two passes,
-    we need to connect the user-written type variables in an LHsQTyVars
-    with the variables in the tycon's inferred kind. Because the tycon might
-    not have a CUSK, this matching up is, in general, quite hard to do.
-    (Look through the git history between Dec 2015 and Apr 2016 for
-    TcHsType.splitTelescopeTvs!) Instead of trying, we just store the list
-    of type variables to bring into scope in the later passes when we create
-    a TcTyCon in getInitialKinds. Much easier this way! These tyvars are
-    brought into scope in kcTyClTyVars and tcTyClTyVars, both in TcHsType.
-
-    It is important that the scoped type variables not be zonked, as some
-    scoped type variables come into existence as SigTvs. If we zonk, the
-    Unique will change and the user-written occurrences won't match up with
-    what we expect.
-
-    In a TcTyCon, everything is zonked (except the scoped vars) after
-    the kind-checking pass.
+This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs.
+
 
 ************************************************************************
 *                                                                      *
@@ -1121,7 +1206,10 @@ tyConRepName_maybe (AlgTyCon { algTcParent = parent })
   | UnboxedAlgTyCon rep_nm <- parent = rep_nm
 tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })
   = Just rep_nm
-tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm })
+tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })
+  | isUnboxedSumCon dc   -- see #13276
+  = Nothing
+  | otherwise
   = Just rep_nm
 tyConRepName_maybe _ = Nothing
 
@@ -1136,7 +1224,7 @@ mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,
     name_mod  = nameModule  tc_name
     name_uniq = nameUnique  tc_name
     rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq
-             | otherwise        = dataConRepNameUnique name_uniq
+             | otherwise        = dataConTyRepNameUnique name_uniq
     (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ
 
 -- | The name (and defining module) for the Typeable representation (TyCon) of a
@@ -1259,19 +1347,25 @@ isGcPtrRep LiftedRep   = True
 isGcPtrRep UnliftedRep = True
 isGcPtrRep _           = False
 
--- | Find the size of a 'PrimRep', in words
-primRepSizeW :: DynFlags -> PrimRep -> Int
-primRepSizeW _      IntRep           = 1
-primRepSizeW _      WordRep          = 1
-primRepSizeW dflags Int64Rep         = wORD64_SIZE `quot` wORD_SIZE dflags
-primRepSizeW dflags Word64Rep        = wORD64_SIZE `quot` wORD_SIZE dflags
-primRepSizeW _      FloatRep         = 1    -- NB. might not take a full word
-primRepSizeW dflags DoubleRep        = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
-primRepSizeW _      AddrRep          = 1
-primRepSizeW _      LiftedRep        = 1
-primRepSizeW _      UnliftedRep      = 1
-primRepSizeW _      VoidRep          = 0
-primRepSizeW dflags (VecRep len rep) = len * primElemRepSizeB rep `quot` wORD_SIZE dflags
+-- | The size of a 'PrimRep' in bytes.
+--
+-- This applies also when used in a constructor, where we allow packing the
+-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will
+-- take only 8 bytes, which for 64-bit arch will be equal to 1 word.
+-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are
+-- layed out.
+primRepSizeB :: DynFlags -> PrimRep -> Int
+primRepSizeB dflags IntRep           = wORD_SIZE dflags
+primRepSizeB dflags WordRep          = wORD_SIZE dflags
+primRepSizeB _      Int64Rep         = wORD64_SIZE
+primRepSizeB _      Word64Rep        = wORD64_SIZE
+primRepSizeB _      FloatRep         = fLOAT_SIZE
+primRepSizeB dflags DoubleRep        = dOUBLE_SIZE dflags
+primRepSizeB dflags AddrRep          = wORD_SIZE dflags
+primRepSizeB dflags LiftedRep        = wORD_SIZE dflags
+primRepSizeB dflags UnliftedRep      = wORD_SIZE dflags
+primRepSizeB _      VoidRep          = 0
+primRepSizeB _      (VecRep len rep) = len * primElemRepSizeB rep
 
 primElemRepSizeB :: PrimElemRep -> Int
 primElemRepSizeB Int8ElemRep   = 1
@@ -1341,7 +1435,7 @@ So we compromise, and move their Kind calculation to the call site.
 -}
 
 -- | Given the name of the function type constructor and it's kind, create the
--- corresponding 'TyCon'. It is recomended to use 'TyCoRep.funTyCon' if you want
+-- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want
 -- this functionality
 mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon
 mkFunTyCon name binders rep_nm
@@ -1446,24 +1540,27 @@ mkSumTyCon name binders res_kind arity tyvars cons parent
         tyConCType       = Nothing,
         algTcGadtSyntax  = False,
         algTcStupidTheta = [],
-        algTcRhs         = SumTyCon { data_cons = cons },
+        algTcRhs         = mkSumTyConRhs cons,
         algTcFields      = emptyDFsEnv,
         algTcParent      = parent
     }
 
--- | Makes a tycon suitable for use during type-checking.
--- The only real need for this is for printing error messages during
--- a recursive type/class type-checking knot. It has a kind because
--- TcErrors sometimes calls typeKind.
+-- | Makes a tycon suitable for use during type-checking. It stores
+-- a variety of details about the definition of the TyCon, but no
+-- right-hand side. It lives only during the type-checking of a
+-- mutually-recursive group of tycons; it is then zonked to a proper
+-- TyCon in zonkTcTyCon.
 -- See also Note [Kind checking recursive type and class declarations]
 -- in TcTyClsDecls.
 mkTcTyCon :: Name
+          -> SDoc                -- ^ user-written tycon tyvars
           -> [TyConBinder]
           -> Kind                -- ^ /result/ kind only
-          -> [TyVar]             -- ^ Scoped type variables, see Note [TcTyCon]
+          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;
+                                 -- see Note [How TcTyCons work] in TcTyClsDecls
           -> TyConFlavour        -- ^ What sort of 'TyCon' this represents
           -> TyCon
-mkTcTyCon name binders res_kind scoped_tvs flav
+mkTcTyCon name tyvars binders res_kind scoped_tvs flav
   = TcTyCon { tyConUnique  = getUnique name
             , tyConName    = name
             , tyConTyVars  = binderVars binders
@@ -1472,7 +1569,8 @@ mkTcTyCon name binders res_kind scoped_tvs flav
             , tyConKind    = mkTyConKind binders res_kind
             , tyConArity   = length binders
             , tcTyConScopedTyVars = scoped_tvs
-            , tcTyConFlavour      = flav }
+            , tcTyConFlavour      = flav
+            , tcTyConUserTyVars   = tyvars }
 
 -- | Create an unlifted primitive 'TyCon', such as @Int#@.
 mkPrimTyCon :: Name -> [TyConBinder]
@@ -1560,7 +1658,7 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj
 -- as the data constructor itself; when we pretty-print
 -- the TyCon we add a quote; see the Outputable TyCon instance
 mkPromotedDataCon :: DataCon -> Name -> TyConRepName
-                  -> [TyConBinder] -> Kind -> [Role]
+                  -> [TyConTyCoBinder] -> Kind -> [Role]
                   -> RuntimeRepInfo -> TyCon
 mkPromotedDataCon con name rep_name binders res_kind roles rep_info
   = PromotedDataCon {
@@ -1585,11 +1683,11 @@ isAbstractTyCon :: TyCon -> Bool
 isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True
 isAbstractTyCon _ = False
 
--- | Make an fake, recovery 'TyCon' from an existing one.
+-- | Make a fake, recovery 'TyCon' from an existing one.
 -- Used when recovering from errors
 makeRecoveryTyCon :: TyCon -> TyCon
 makeRecoveryTyCon tc
-  = mkTcTyCon (tyConName tc)
+  = mkTcTyCon (tyConName tc) empty
               (tyConBinders tc) (tyConResKind tc)
               [{- no scoped vars -}]
               (tyConFlavour tc)
@@ -1666,7 +1764,7 @@ isInjectiveTyCon (PrimTyCon {})                _                = True
 isInjectiveTyCon (PromotedDataCon {})          _                = True
 isInjectiveTyCon (TcTyCon {})                  _                = True
   -- Reply True for TcTyCon to minimise knock on type errors
-  -- See Note [TcTyCon] item (1)
+  -- See Note [How TcTyCons work] item (1) in TcTyClsDecls
 
 -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds
 -- (where X is the role passed in):
@@ -1692,8 +1790,9 @@ isNewTyCon :: TyCon -> Bool
 isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True
 isNewTyCon _                                   = False
 
--- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands
--- into, and (possibly) a coercion from the representation type to the @newtype@.
+-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it
+-- expands into, and (possibly) a coercion from the representation type to the
+-- @newtype@.
 -- Returns @Nothing@ if this is not possible.
 unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)
 unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
@@ -1716,7 +1815,7 @@ isProductTyCon tc@(AlgTyCon {})
   = case algTcRhs tc of
       TupleTyCon {} -> True
       DataTyCon{ data_cons = [data_con] }
-                    -> null (dataConExTyVars data_con)
+                    -> null (dataConExTyCoVars data_con)
       NewTyCon {}   -> True
       _             -> False
 isProductTyCon _ = False
@@ -1728,7 +1827,7 @@ isDataProductTyCon_maybe :: TyCon -> Maybe DataCon
 isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })
   = case rhs of
        DataTyCon { data_cons = [con] }
-         | null (dataConExTyVars con)  -- non-existential
+         | null (dataConExTyCoVars con)  -- non-existential
          -> Just con
        TupleTyCon { data_con = con }
          -> Just con
@@ -1740,10 +1839,10 @@ isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })
   = case rhs of
       DataTyCon { data_cons = cons }
         | cons `lengthExceeds` 1
-        , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?
+        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?
         -> Just cons
       SumTyCon { data_cons = cons }
-        | all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?
+        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?
         -> Just cons
       _ -> Nothing
 isDataSumTyCon_maybe _ = Nothing
@@ -1855,11 +1954,17 @@ isClosedSynFamilyTyConWithAxiom_maybe
   (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb
 isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing
 
--- | Try to read the injectivity information from a FamilyTyCon.
--- For every other TyCon this function panics.
-familyTyConInjectivityInfo :: TyCon -> Injectivity
-familyTyConInjectivityInfo (FamilyTyCon { famTcInj = inj }) = inj
-familyTyConInjectivityInfo _ = panic "familyTyConInjectivityInfo"
+-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an
+-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is
+-- injective), or 'NotInjective' otherwise.
+tyConInjectivityInfo :: TyCon -> Injectivity
+tyConInjectivityInfo tc
+  | FamilyTyCon { famTcInj = inj } <- tc
+  = inj
+  | isInjectiveTyCon tc Nominal
+  = Injective (replicate (tyConArity tc) True)
+  | otherwise
+  = NotInjective
 
 isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
 isBuiltInSynFamTyCon_maybe
@@ -1944,18 +2049,14 @@ isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys
 -- -XDataKinds.
 kindTyConKeys :: UniqSet Unique
 kindTyConKeys = unionManyUniqSets
-  ( mkUniqSet [ liftedTypeKindTyConKey, starKindTyConKey, unicodeStarKindTyConKey
-              , constraintKindTyConKey, tYPETyConKey ]
+  ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ]
   : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon
                                           , vecCountTyCon, vecElemTyCon ] )
   where
     tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)
 
 isLiftedTypeKindTyConName :: Name -> Bool
-isLiftedTypeKindTyConName
-  = (`hasKey` liftedTypeKindTyConKey) <||>
-    (`hasKey` starKindTyConKey) <||>
-    (`hasKey` unicodeStarKindTyConKey)
+isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)
 
 -- | Identifies implicit tycons that, in particular, do not go into interface
 -- files (because they are implicitly reconstructed when the interface is
@@ -2038,6 +2139,10 @@ expandSynTyCon_maybe tc tys
 -- | Check if the tycon actually refers to a proper `data` or `newtype`
 --  with user defined constructors rather than one from a class or other
 --  construction.
+
+-- NB: This is only used in TcRnExports.checkPatSynParent to determine if an
+-- exported tycon can have a pattern synonym bundled with it, e.g.,
+-- module Foo (TyCon(.., PatSyn)) where
 isTyConWithSrcDataCons :: TyCon -> Bool
 isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =
   case rhs of
@@ -2047,6 +2152,8 @@ isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) =
     _ -> False
   where
     isSrcParent = isNoParent parent
+isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} })
+                         = True -- #14058
 isTyConWithSrcDataCons _ = False
 
 
@@ -2105,10 +2212,10 @@ tyConSingleAlgDataCon_maybe _        = Nothing
 tyConFamilySize  :: TyCon -> Int
 tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs })
   = case rhs of
-      DataTyCon { data_cons = cons } -> length cons
+      DataTyCon { data_cons_size = size } -> size
       NewTyCon {}                    -> 1
       TupleTyCon {}                  -> 1
-      SumTyCon { data_cons = cons }  -> length cons
+      SumTyCon { data_cons_size = size }  -> size
       _                              -> pprPanic "tyConFamilySize 1" (ppr tc)
 tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc)
 
@@ -2252,6 +2359,28 @@ tyConRuntimeRepInfo _                                         = NoRRI
   -- could panic in that second case. But Douglas Adams told me not to.
 
 {-
+Note [Constructor tag allocation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking we need to allocate constructor tags to constructors.
+They are allocated based on the position in the data_cons field of TyCon,
+with the first constructor getting fIRST_TAG.
+
+We used to pay linear cost per constructor, with each constructor looking up
+its relative index in the constructor list. That was quadratic and prohibitive
+for large data types with more than 10k constructors.
+
+The current strategy is to build a NameEnv with a mapping from costructor's
+Name to ConTag and pass it down to buildDataCon for efficient lookup.
+
+Relevant ticket: #14657
+-}
+
+mkTyConTagMap :: TyCon -> NameEnv ConTag
+mkTyConTagMap tycon =
+  mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..]
+  -- See Note [Constructor tag allocation]
+
+{-
 ************************************************************************
 *                                                                      *
 \subsection[TyCon-instances]{Instance declarations for @TyCon@}
@@ -2271,7 +2400,11 @@ instance Uniquable TyCon where
 instance Outputable TyCon where
   -- At the moment a promoted TyCon has the same Name as its
   -- corresponding TyCon, so we add the quote to distinguish it here
-  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc)
+  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc
+    where
+      pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc)
+                                    then text "[tc]"
+                                    else empty
 
 -- | Paints a picture of what a 'TyCon' represents, in broad strokes.
 -- This is used towards more informative error messages.
@@ -2282,8 +2415,8 @@ data TyConFlavour
   | DataTypeFlavour
   | NewtypeFlavour
   | AbstractTypeFlavour
-  | DataFamilyFlavour
-  | OpenTypeFamilyFlavour
+  | DataFamilyFlavour Bool     -- True <=> associated
+  | OpenTypeFamilyFlavour Bool -- True <=> associated
   | ClosedTypeFamilyFlavour
   | TypeSynonymFlavour
   | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.
@@ -2300,8 +2433,10 @@ instance Outputable TyConFlavour where
       go DataTypeFlavour         = "data type"
       go NewtypeFlavour          = "newtype"
       go AbstractTypeFlavour     = "abstract type"
-      go DataFamilyFlavour       = "data family"
-      go OpenTypeFamilyFlavour   = "type family"
+      go (DataFamilyFlavour True)      = "associated data family"
+      go (DataFamilyFlavour False)     = "data family"
+      go (OpenTypeFamilyFlavour True)  = "associated type family"
+      go (OpenTypeFamilyFlavour False) = "type family"
       go ClosedTypeFamilyFlavour = "type family"
       go TypeSynonymFlavour      = "type synonym"
       go BuiltInTypeFlavour      = "built-in type"
@@ -2317,10 +2452,10 @@ tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs })
                   DataTyCon {}       -> DataTypeFlavour
                   NewTyCon {}        -> NewtypeFlavour
                   AbstractTyCon {}   -> AbstractTypeFlavour
-tyConFlavour (FamilyTyCon { famTcFlav = flav })
+tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent })
   = case flav of
-      DataFamilyTyCon{}            -> DataFamilyFlavour
-      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour
+      DataFamilyTyCon{}            -> DataFamilyFlavour (isJust parent)
+      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour (isJust parent)
       ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour
       AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour
       BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour
@@ -2335,20 +2470,20 @@ tcFlavourCanBeUnsaturated :: TyConFlavour -> Bool
 tcFlavourCanBeUnsaturated ClassFlavour            = True
 tcFlavourCanBeUnsaturated DataTypeFlavour         = True
 tcFlavourCanBeUnsaturated NewtypeFlavour          = True
-tcFlavourCanBeUnsaturated DataFamilyFlavour       = True
+tcFlavourCanBeUnsaturated DataFamilyFlavour{}     = True
 tcFlavourCanBeUnsaturated TupleFlavour{}          = True
 tcFlavourCanBeUnsaturated SumFlavour              = True
 tcFlavourCanBeUnsaturated AbstractTypeFlavour     = True
 tcFlavourCanBeUnsaturated BuiltInTypeFlavour      = True
 tcFlavourCanBeUnsaturated PromotedDataConFlavour  = True
 tcFlavourCanBeUnsaturated TypeSynonymFlavour      = False
-tcFlavourCanBeUnsaturated OpenTypeFamilyFlavour   = False
+tcFlavourCanBeUnsaturated OpenTypeFamilyFlavour{} = False
 tcFlavourCanBeUnsaturated ClosedTypeFamilyFlavour = False
 
 -- | Is this flavour of 'TyCon' an open type family or a data family?
 tcFlavourIsOpen :: TyConFlavour -> Bool
-tcFlavourIsOpen DataFamilyFlavour       = True
-tcFlavourIsOpen OpenTypeFamilyFlavour   = True
+tcFlavourIsOpen DataFamilyFlavour{}     = True
+tcFlavourIsOpen OpenTypeFamilyFlavour{} = True
 tcFlavourIsOpen ClosedTypeFamilyFlavour = False
 tcFlavourIsOpen ClassFlavour            = False
 tcFlavourIsOpen DataTypeFlavour         = False
@@ -2437,10 +2572,20 @@ data RecTcChecker = RC !Int (NameEnv Int)
   -- The upper bound, and the number of times
   -- we have encountered each TyCon
 
+-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
 initRecTc :: RecTcChecker
--- Intialise with a fixed max bound of 100
--- We should probably have a flag for this
-initRecTc = RC 100 emptyNameEnv
+initRecTc = RC defaultRecTcMaxBound emptyNameEnv
+
+-- | The default upper bound (100) for the number of times a 'RecTcChecker' is
+-- allowed to encounter each 'TyCon'.
+defaultRecTcMaxBound :: Int
+defaultRecTcMaxBound = 100
+-- Should we have a flag for this?
+
+-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
+-- to encounter each 'TyCon'.
+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts
 
 checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
 -- Nothing      => Recursion detected
diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot
index d77ed8a172..4db8d0f1c1 100644
--- a/compiler/types/TyCon.hs-boot
+++ b/compiler/types/TyCon.hs-boot
@@ -1,5 +1,7 @@
 module TyCon where
 
+import GhcPrelude
+
 data TyCon
 
 isTupleTyCon        :: TyCon -> Bool
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 8621e6cd52..bda3602815 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -15,11 +15,12 @@ module Type (
 
         -- $representation_types
         TyThing(..), Type, ArgFlag(..), KindOrType, PredType, ThetaType,
-        Var, TyVar, isTyVar, TyCoVar, TyBinder, TyVarBinder,
+        Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,
+        KnotTied,
 
         -- ** Constructing and deconstructing types
         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,
-        getCastedTyVar_maybe, tyVarKind,
+        getCastedTyVar_maybe, tyVarKind, varType,
 
         mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,
         splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,
@@ -35,18 +36,22 @@ module Type (
         splitListTyConApp_maybe,
         repSplitTyConApp_maybe,
 
-        mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys,
-        mkVisForAllTys, mkInvForAllTy,
-        splitForAllTys, splitForAllTyVarBndrs,
+        mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys,
+        mkVisForAllTys, mkTyCoInvForAllTy,
+        mkInvForAllTy, mkInvForAllTys,
+        splitForAllTys, splitForAllVarBndrs,
         splitForAllTy_maybe, splitForAllTy,
+        splitForAllTy_ty_maybe, splitForAllTy_co_maybe,
         splitPiTy_maybe, splitPiTy, splitPiTys,
-        mkPiTy, mkPiTys, mkTyConBindersPreferAnon,
+        mkTyCoPiTy, mkTyCoPiTys, mkTyConBindersPreferAnon,
+        mkPiTys,
         mkLamType, mkLamTypes,
         piResultTy, piResultTys,
         applyTysX, dropForAlls,
 
         mkNumLitTy, isNumLitTy,
         mkStrLitTy, isStrLitTy,
+        isLitTy,
 
         getRuntimeRep_maybe, getRuntimeRepFromKind_maybe,
 
@@ -58,7 +63,7 @@ module Type (
         stripCoercionTy, splitCoercionType_maybe,
 
         splitPiTysInvisible, filterOutInvisibleTypes,
-        filterOutInvisibleTyVars, partitionInvisibles,
+        partitionInvisibleTypes, partitionInvisibles,
         synTyConResKind,
 
         modifyJoinResTy, setJoinResTy,
@@ -88,15 +93,16 @@ module Type (
 
         -- ** Binders
         sameVis,
-        mkTyVarBinder, mkTyVarBinders,
+        mkTyCoVarBinder, mkTyCoVarBinders,
+        mkTyVarBinders,
         mkAnonBinder,
-        isAnonTyBinder, isNamedTyBinder,
-        binderVar, binderVars, binderKind, binderArgFlag,
+        isAnonTyCoBinder, isNamedTyCoBinder,
+        binderVar, binderVars, binderType, binderArgFlag,
+        tyCoBinderType, tyCoBinderVar_maybe,
         tyBinderType,
         binderRelevantType_maybe, caseBinder,
         isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder,
-        tyConBindersTyBinders,
-        mkTyBinderTyConBinder,
+        tyConBindersTyCoBinders,
 
         -- ** Common type constructors
         funTyCon,
@@ -104,13 +110,14 @@ module Type (
         -- ** Predicates on types
         isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy,
         isCoercionTy_maybe, isCoercionType, isForAllTy,
+        isForAllTy_ty, isForAllTy_co,
         isPiTy, isTauTy, isFamFreeTy,
 
         isValidJoinPointType,
 
         -- (Lifting and boxity)
         isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType,
-        isAlgType, isClosedAlgType, isDataFamilyAppType,
+        isAlgType, isDataFamilyAppType,
         isPrimitiveType, isStrictType,
         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
         dropRuntimeRepArgs,
@@ -121,6 +128,7 @@ module Type (
 
         -- ** Finding the kind of a type
         typeKind, isTypeLevPoly, resultIsLevPoly,
+        tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
 
         -- ** Common Kind
         liftedTypeKind,
@@ -134,7 +142,7 @@ module Type (
         noFreeVarsOfType,
         splitVisVarsOfType, splitVisVarsOfTypes,
         expandTypeSynonyms,
-        typeSize,
+        typeSize, occCheckExpand,
 
         -- * Well-scoped lists of variables
         dVarSetElemsWellScoped, toposortTyVars, tyCoVarsOfTypeWellScoped,
@@ -161,14 +169,17 @@ module Type (
         emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
 
         mkTCvSubst, zipTvSubst, mkTvSubstPrs,
+        zipTCvSubst,
         notElemTCvSubst,
         getTvSubstEnv, setTvSubstEnv,
         zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,
         extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,
         extendTCvSubst, extendCvSubst,
-        extendTvSubst, extendTvSubstBinder,
+        extendTvSubst, extendTvSubstBinderAndInScope,
         extendTvSubstList, extendTvSubstAndInScope,
+        extendTCvSubstList,
         extendTvSubstWithClone,
+        extendTCvSubstWithClone,
         isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,
         isEmptyTCvSubst, unionTCvSubst,
 
@@ -178,33 +189,37 @@ module Type (
         substTyUnchecked, substTysUnchecked, substThetaUnchecked,
         substTyWithUnchecked,
         substCoUnchecked, substCoWithUnchecked,
-        substTyVarBndr, substTyVar, substTyVars,
+        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
+        substVarBndr, substVarBndrs,
         cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,
 
         -- * Pretty-printing
         pprType, pprParendType, pprPrecType,
         pprTypeApp, pprTyThingCategory, pprShortTyThing,
-        pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll,
+        pprTCvBndr, pprTCvBndrs, pprForAll, pprUserForAll,
         pprSigmaType, ppSuggestExplicitKinds,
         pprTheta, pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprSourceTyCon,
-        TyPrec(..), maybeParen,
-        pprTyVar, pprTyVars, pprPrefixApp, pprArrowChain,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
+        pprTyVar, pprTyVars,
+        pprWithTYPE,
 
         -- * Tidying type related things up for printing
         tidyType,      tidyTypes,
         tidyOpenType,  tidyOpenTypes,
         tidyOpenKind,
-        tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars,
+        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,
         tidyOpenTyCoVar, tidyOpenTyCoVars,
-        tidyTyVarOcc,
+        tidyTyCoVarOcc,
         tidyTopType,
         tidyKind,
-        tidyTyVarBinder, tidyTyVarBinders
+        tidyTyCoVarBinder, tidyTyCoVarBinders
     ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import BasicTypes
 
 -- We import the representation and primitive functions from TyCoRep.
@@ -226,19 +241,23 @@ import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind
                                  , typeSymbolKind, liftedTypeKind )
 import PrelNames
 import CoAxiom
-import {-# SOURCE #-} Coercion
+import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo
+                              , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo
+                              , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo
+                              , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo
+                              , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo
+                              , decomposePiCos, coercionKind, coercionType
+                              , isReflexiveCo, seqCo )
 
 -- others
 import Util
 import Outputable
 import FastString
 import Pair
+import DynFlags  ( gopt_set, GeneralFlag(Opt_PrintExplicitRuntimeReps) )
 import ListSetOps
 import Digraph
 import Unique ( nonDetCmpUnique )
-import SrcLoc  ( SrcSpan )
-import OccName ( OccName )
-import Name    ( mkInternalName )
 
 import Maybes           ( orElse )
 import Data.Maybe       ( isJust, mapMaybe )
@@ -298,7 +317,7 @@ import Control.Arrow    ( first, second )
 --
 -- You don't normally have to worry about this, as the utility functions in
 -- this module will automatically convert a source into a representation type
--- if they are spotted, to the best of it's abilities. If you don't want this
+-- if they are spotted, to the best of its abilities. If you don't want this
 -- to happen, use the equivalent functions from the "TcType" module.
 
 {-
@@ -321,33 +340,10 @@ See also Trac #11715, which tracks removing this inconsistency.
 
 -}
 
-{-# INLINE coreView #-}
-coreView :: Type -> Maybe Type
--- ^ This function Strips off the /top layer only/ of a type synonym
--- application (if any) its underlying representation type.
--- Returns Nothing if there is nothing to look through.
--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.
---
--- By being non-recursive and inlined, this case analysis gets efficiently
--- joined onto the case analysis that the caller is already doing
-coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's
-               -- ok to use 'substTy' here.
-               -- See also Note [The substitution invariant] in TyCoRep.
-               -- Its important to use mkAppTys, rather than (foldl AppTy),
-               -- because the function part might well return a
-               -- partially-applied type constructor; indeed, usually will!
-coreView (TyConApp tc [])
-  | isStarKindSynonymTyCon tc
-  = Just liftedTypeKind
-
-coreView _ = Nothing
-
 -- | Gives the typechecker view of a type. This unwraps synonyms but
 -- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into
 -- TYPE LiftedRep. Returns Nothing if no unwrapping happens.
--- See also Note [coreView vs tcView] in Type.
+-- See also Note [coreView vs tcView]
 {-# INLINE tcView #-}
 tcView :: Type -> Maybe Type
 tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
@@ -360,6 +356,28 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
                -- partially-applied type constructor; indeed, usually will!
 tcView _ = Nothing
 
+{-# INLINE coreView #-}
+coreView :: Type -> Maybe Type
+-- ^ This function Strips off the /top layer only/ of a type synonym
+-- application (if any) its underlying representation type.
+-- Returns Nothing if there is nothing to look through.
+-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.
+--
+-- By being non-recursive and inlined, this case analysis gets efficiently
+-- joined onto the case analysis that the caller is already doing
+coreView ty@(TyConApp tc tys)
+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')
+    -- This equation is exactly like tcView
+
+  -- At the Core level, Constraint = Type
+  -- See Note [coreView vs tcView]
+  | isConstraintKindCon tc
+  = ASSERT2( null tys, ppr ty )
+    Just liftedTypeKind
+
+coreView _ = Nothing
+
 -----------------------------------------------
 expandTypeSynonyms :: Type -> Type
 -- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out
@@ -396,14 +414,19 @@ expandTypeSynonyms ty
     go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)
     go subst (FunTy arg res)
       = mkFunTy (go subst arg) (go subst res)
-    go subst (ForAllTy (TvBndr tv vis) t)
-      = let (subst', tv') = substTyVarBndrCallback go subst tv in
-        ForAllTy (TvBndr tv' vis) (go subst' t)
+    go subst (ForAllTy (Bndr tv vis) t)
+      = let (subst', tv') = substVarBndrUsing go subst tv in
+        ForAllTy (Bndr tv' vis) (go subst' t)
     go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)
     go subst (CoercionTy co) = mkCoercionTy (go_co subst co)
 
-    go_co subst (Refl r ty)
-      = mkReflCo r (go subst ty)
+    go_mco _     MRefl    = MRefl
+    go_mco subst (MCo co) = MCo (go_co subst co)
+
+    go_co subst (Refl ty)
+      = mkNomReflCo (go subst ty)
+    go_co subst (GRefl r ty mco)
+      = mkGReflCo r (go subst ty) (go_mco subst mco)
        -- NB: coercions are always expanded upon creation
     go_co subst (TyConAppCo r tc args)
       = mkTyConAppCo r tc (map (go_co subst) args)
@@ -424,31 +447,31 @@ expandTypeSynonyms ty
       = mkSymCo (go_co subst co)
     go_co subst (TransCo co1 co2)
       = mkTransCo (go_co subst co1) (go_co subst co2)
-    go_co subst (NthCo n co)
-      = mkNthCo n (go_co subst co)
+    go_co subst (NthCo r n co)
+      = mkNthCo r n (go_co subst co)
     go_co subst (LRCo lr co)
       = mkLRCo lr (go_co subst co)
     go_co subst (InstCo co arg)
       = mkInstCo (go_co subst co) (go_co subst arg)
-    go_co subst (CoherenceCo co1 co2)
-      = mkCoherenceCo (go_co subst co1) (go_co subst co2)
     go_co subst (KindCo co)
       = mkKindCo (go_co subst co)
     go_co subst (SubCo co)
       = mkSubCo (go_co subst co)
-    go_co subst (AxiomRuleCo ax cs) = AxiomRuleCo ax (map (go_co subst) cs)
+    go_co subst (AxiomRuleCo ax cs)
+      = AxiomRuleCo ax (map (go_co subst) cs)
+    go_co _ (HoleCo h)
+      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)
 
     go_prov _     UnsafeCoerceProv    = UnsafeCoerceProv
     go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)
     go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)
     go_prov _     p@(PluginProv _)    = p
-    go_prov _     (HoleProv h)        = pprPanic "expandTypeSynonyms hit a hole" (ppr h)
 
       -- the "False" and "const" are to accommodate the type of
-      -- substForAllCoBndrCallback, which is general enough to
+      -- substForAllCoBndrUsing, which is general enough to
       -- handle coercion optimization (which sometimes swaps the
       -- order of a coercion)
-    go_cobndr subst = substForAllCoBndrCallback False (go_co subst) subst
+    go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst
 
 {-
 ************************************************************************
@@ -463,11 +486,11 @@ on all variables and binding sites. Primarily used for zonking.
 Note [Efficiency for mapCoercion ForAllCo case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant.
-It stores a TyVar and a Coercion, where the kind of the TyVar always matches
+It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches
 the left-hand kind of the coercion. This is convenient lots of the time, but
 not when mapping a function over a coercion.
 
-The problem is that tcm_tybinder will affect the TyVar's kind and
+The problem is that tcm_tybinder will affect the TyCoVar's kind and
 mapCoercion will affect the Coercion, and we hope that the results will be
 the same. Even if they are the same (which should generally happen with
 correct algorithms), then there is an efficiency issue. In particular,
@@ -494,35 +517,42 @@ this one change made a 20% allocation difference in perf/compiler/T5030.
 data TyCoMapper env m
   = TyCoMapper
       { tcm_smart :: Bool -- ^ Should the new type be created with smart
-                         -- constructors?
+                          -- constructors?
       , tcm_tyvar :: env -> TyVar -> m Type
       , tcm_covar :: env -> CoVar -> m Coercion
-      , tcm_hole  :: env -> CoercionHole -> Role
-                  -> Type -> Type -> m Coercion
-          -- ^ What to do with coercion holes. See Note [Coercion holes] in
-          -- TyCoRep.
+      , tcm_hole  :: env -> CoercionHole -> m Coercion
+          -- ^ What to do with coercion holes.
+          -- See Note [Coercion holes] in TyCoRep.
 
-      , tcm_tybinder :: env -> TyVar -> ArgFlag -> m (env, TyVar)
+      , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar)
           -- ^ The returned env is used in the extended scope
+
+      , tcm_tycon :: TyCon -> m TyCon
+          -- ^ This is used only to turn 'TcTyCon's into 'TyCon's.
+          -- See Note [Type checking recursive type and class declarations]
+          -- in TcTyClsDecls
       }
 
 {-# INLINABLE mapType #-}  -- See Note [Specialising mappers]
 mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type
 mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
-                           , tcm_tybinder = tybinder })
+                           , tcm_tycobinder = tycobinder, tcm_tycon = tycon })
         env ty
   = go ty
   where
     go (TyVarTy tv) = tyvar env tv
     go (AppTy t1 t2) = mkappty <$> go t1 <*> go t2
-    go t@(TyConApp _ []) = return t  -- avoid allocation in this exceedingly
-                                     -- common case (mostly, for *)
-    go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys
+    go t@(TyConApp tc []) | not (isTcTyCon tc)
+                          = return t  -- avoid allocation in this exceedingly
+                                      -- common case (mostly, for *)
+    go (TyConApp tc tys)
+      = do { tc' <- tycon tc
+           ; mktyconapp tc' <$> mapM go tys }
     go (FunTy arg res)   = FunTy <$> go arg <*> go res
-    go (ForAllTy (TvBndr tv vis) inner)
-      = do { (env', tv') <- tybinder env tv vis
+    go (ForAllTy (Bndr tv vis) inner)
+      = do { (env', tv') <- tycobinder env tv vis
            ; inner' <- mapType mapper env' inner
-           ; return $ ForAllTy (TvBndr tv' vis) inner' }
+           ; return $ ForAllTy (Bndr tv' vis) inner' }
     go ty@(LitTy {})   = return ty
     go (CastTy ty co)  = mkcastty <$> go ty <*> mapCoercion mapper env co
     go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co
@@ -535,17 +565,23 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar
 mapCoercion :: Monad m
             => TyCoMapper env m -> env -> Coercion -> m Coercion
 mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
-                               , tcm_hole = cohole, tcm_tybinder = tybinder })
+                               , tcm_hole = cohole, tcm_tycobinder = tycobinder
+                               , tcm_tycon = tycon })
             env co
   = go co
   where
-    go (Refl r ty) = Refl r <$> mapType mapper env ty
+    go_mco MRefl    = return MRefl
+    go_mco (MCo co) = MCo <$> (go co)
+
+    go (Refl ty) = Refl <$> mapType mapper env ty
+    go (GRefl r ty mco) = mkgreflco r <$> mapType mapper env ty <*> (go_mco mco)
     go (TyConAppCo r tc args)
-      = mktyconappco r tc <$> mapM go args
+      = do { tc' <- tycon tc
+           ; mktyconappco r tc' <$> mapM go args }
     go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2
     go (ForAllCo tv kind_co co)
       = do { kind_co' <- go kind_co
-           ; (env', tv') <- tybinder env tv Inferred
+           ; (env', tv') <- tycobinder env tv Inferred
            ; co' <- mapCoercion mapper env' co
            ; return $ mkforallco tv' kind_co' co' }
         -- See Note [Efficiency for mapCoercion ForAllCo case]
@@ -553,18 +589,16 @@ mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
     go (CoVarCo cv) = covar env cv
     go (AxiomInstCo ax i args)
       = mkaxiominstco ax i <$> mapM go args
-    go (UnivCo (HoleProv hole) r t1 t2)
-      = cohole env hole r t1 t2
+    go (HoleCo hole) = cohole env hole
     go (UnivCo p r t1 t2)
       = mkunivco <$> go_prov p <*> pure r
                  <*> mapType mapper env t1 <*> mapType mapper env t2
     go (SymCo co) = mksymco <$> go co
     go (TransCo c1 c2) = mktransco <$> go c1 <*> go c2
     go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos
-    go (NthCo i co)        = mknthco i <$> go co
+    go (NthCo r i co)      = mknthco r i <$> go co
     go (LRCo lr co)        = mklrco lr <$> go co
     go (InstCo co arg)     = mkinstco <$> go co <*> go arg
-    go (CoherenceCo c1 c2) = mkcoherenceco <$> go c1 <*> go c2
     go (KindCo co)         = mkkindco <$> go co
     go (SubCo co)          = mksubco <$> go co
 
@@ -572,19 +606,18 @@ mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar
     go_prov (PhantomProv co)    = PhantomProv <$> go co
     go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co
     go_prov p@(PluginProv _)    = return p
-    go_prov (HoleProv _)        = panic "mapCoercion"
 
     ( mktyconappco, mkappco, mkaxiominstco, mkunivco
-      , mksymco, mktransco, mknthco, mklrco, mkinstco, mkcoherenceco
-      , mkkindco, mksubco, mkforallco)
+      , mksymco, mktransco, mknthco, mklrco, mkinstco
+      , mkkindco, mksubco, mkforallco, mkgreflco)
       | smart
       = ( mkTyConAppCo, mkAppCo, mkAxiomInstCo, mkUnivCo
-        , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo, mkCoherenceCo
-        , mkKindCo, mkSubCo, mkForAllCo )
+        , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo
+        , mkKindCo, mkSubCo, mkForAllCo, mkGReflCo )
       | otherwise
       = ( TyConAppCo, AppCo, AxiomInstCo, UnivCo
-        , SymCo, TransCo, NthCo, LRCo, InstCo, CoherenceCo
-        , KindCo, SubCo, ForAllCo )
+        , SymCo, TransCo, NthCo, LRCo, InstCo
+        , KindCo, SubCo, ForAllCo, GRefl )
 
 {-
 ************************************************************************
@@ -615,8 +648,8 @@ getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
                   | otherwise               = repGetTyVar_maybe ty
 
 -- | If the type is a tyvar, possibly under a cast, returns it, along
--- with the coercion. Thus, the co is :: kind tv ~R kind type
-getCastedTyVar_maybe :: Type -> Maybe (TyVar, Coercion)
+-- with the coercion. Thus, the co is :: kind tv ~N kind ty
+getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
 getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty'
 getCastedTyVar_maybe (CastTy (TyVarTy tv) co)     = Just (tv, co)
 getCastedTyVar_maybe (TyVarTy tv)
@@ -661,6 +694,11 @@ the type checker (e.g. when matching type-function equations).
 
 -- | Applies a type to another, as in e.g. @k a@
 mkAppTy :: Type -> Type -> Type
+  -- See Note [Respecting definitional equality], invariant (EQ1).
+mkAppTy (CastTy fun_ty co) arg_ty
+  | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]
+  = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co
+
 mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])
 mkAppTy ty1               ty2 = AppTy ty1 ty2
         -- Note that the TyConApp could be an
@@ -674,8 +712,17 @@ mkAppTy ty1               ty2 = AppTy ty1 ty2
 
 mkAppTys :: Type -> [Type] -> Type
 mkAppTys ty1                []   = ty1
+mkAppTys (CastTy fun_ty co) arg_tys  -- much more efficient then nested mkAppTy
+                                     -- Why do this? See (EQ1) of
+                                     -- Note [Respecting definitional equality]
+                                     -- in TyCoRep
+  = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers
+  where
+    (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys
+    (args_to_cast, leftovers) = splitAtList arg_cos arg_tys
+    casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos
 mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)
-mkAppTys ty1                tys2 = foldl AppTy ty1 tys2
+mkAppTys ty1                tys2 = foldl' AppTy ty1 tys2
 
 -------------
 splitAppTy_maybe :: Type -> Maybe (Type, Type)
@@ -687,40 +734,41 @@ splitAppTy_maybe ty | Just ty' <- coreView ty
 splitAppTy_maybe ty = repSplitAppTy_maybe ty
 
 -------------
-repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
+repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)
 -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
 -- any Core view stuff is already done
 repSplitAppTy_maybe (FunTy ty1 ty2)
-  | Just rep1 <- getRuntimeRep_maybe ty1
-  , Just rep2 <- getRuntimeRep_maybe ty2
   = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
+  where
+    rep1 = getRuntimeRep ty1
+    rep2 = getRuntimeRep ty2
 
-  | otherwise
-  = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
 repSplitAppTy_maybe (AppTy ty1 ty2)
   = Just (ty1, ty2)
+
 repSplitAppTy_maybe (TyConApp tc tys)
   | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
   , Just (tys', ty') <- snocView tys
   = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!
+
 repSplitAppTy_maybe _other = Nothing
 
--- this one doesn't braek apart (c => t).
+-- This one doesn't break apart (c => t).
 -- See Note [Decomposing fat arrow c=>t]
 -- Defined here to avoid module loops between Unify and TcType.
 tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)
 -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that
 -- any coreView stuff is already done. Refuses to look through (c => t)
 tcRepSplitAppTy_maybe (FunTy ty1 ty2)
-  | isConstraintKind (typeKind ty1)
+  | isPredTy ty1
   = Nothing  -- See Note [Decomposing fat arrow c=>t]
 
-  | Just rep1 <- getRuntimeRep_maybe ty1
-  , Just rep2 <- getRuntimeRep_maybe ty2
+  | otherwise
   = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2)
+  where
+    rep1 = getRuntimeRep ty1
+    rep2 = getRuntimeRep ty2
 
-  | otherwise
-  = pprPanic "repSplitAppTy_maybe" (ppr ty1 $$ ppr ty2)
 tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2)
 tcRepSplitAppTy_maybe (TyConApp tc tys)
   | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc
@@ -728,31 +776,20 @@ tcRepSplitAppTy_maybe (TyConApp tc tys)
   = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!
 tcRepSplitAppTy_maybe _other = Nothing
 
--- | Split a type constructor application into its type constructor and
--- applied types. Note that this may fail in the case of a 'FunTy' with an
--- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind
--- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your
--- type before using this function.
---
--- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.
-tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
--- Defined here to avoid module loops between Unify and TcType.
-tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
-tcSplitTyConApp_maybe ty                         = tcRepSplitTyConApp_maybe ty
-
 -- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms.
 tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
 -- Defined here to avoid module loops between Unify and TcType.
-tcRepSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)
+tcRepSplitTyConApp_maybe (TyConApp tc tys)
+  = Just (tc, tys)
+
 tcRepSplitTyConApp_maybe (FunTy arg res)
-  | Just arg_rep <- getRuntimeRep_maybe arg
-  , Just res_rep <- getRuntimeRep_maybe res
   = Just (funTyCon, [arg_rep, res_rep, arg, res])
+  where
+    arg_rep = getRuntimeRep arg
+    res_rep = getRuntimeRep res
 
-  | otherwise
-  = pprPanic "tcRepSplitTyConApp_maybe" (ppr arg $$ ppr res)
-tcRepSplitTyConApp_maybe _                          = Nothing
-
+tcRepSplitTyConApp_maybe _
+  = Nothing
 
 -------------
 splitAppTy :: Type -> (Type, Type)
@@ -779,17 +816,16 @@ splitAppTys ty = split ty ty []
         in
         (TyConApp tc tc_args1, tc_args2 ++ args)
     split _   (FunTy ty1 ty2) args
-      | Just rep1 <- getRuntimeRep_maybe ty1
-      , Just rep2 <- getRuntimeRep_maybe ty2
       = ASSERT( null args )
         (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])
+      where
+        rep1 = getRuntimeRep ty1
+        rep2 = getRuntimeRep ty2
 
-      | otherwise
-      = pprPanic "splitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
     split orig_ty _                     args  = (orig_ty, args)
 
 -- | Like 'splitAppTys', but doesn't look through type synonyms
-repSplitAppTys :: Type -> (Type, [Type])
+repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
 repSplitAppTys ty = split ty []
   where
     split (AppTy ty arg) args = split ty (arg:args)
@@ -800,13 +836,12 @@ repSplitAppTys ty = split ty []
         in
         (TyConApp tc tc_args1, tc_args2 ++ args)
     split (FunTy ty1 ty2) args
-      | Just rep1 <- getRuntimeRep_maybe ty1
-      , Just rep2 <- getRuntimeRep_maybe ty2
       = ASSERT( null args )
         (TyConApp funTyCon [], [rep1, rep2, ty1, ty2])
+      where
+        rep1 = getRuntimeRep ty1
+        rep2 = getRuntimeRep ty2
 
-      | otherwise
-      = pprPanic "repSplitAppTys" (ppr ty1 $$ ppr ty2 $$ ppr args)
     split ty args = (ty, args)
 
 {-
@@ -832,6 +867,11 @@ isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1
 isStrLitTy (LitTy (StrTyLit s)) = Just s
 isStrLitTy _                    = Nothing
 
+-- | Is this a type literal (symbol or numeric).
+isLitTy :: Type -> Maybe TyLit
+isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1
+isLitTy (LitTy l)                    = Just l
+isLitTy _                            = Nothing
 
 -- | Is this type a custom user error?
 -- If so, give us the kind and the error message.
@@ -868,7 +908,7 @@ pprUserTypeErrorTy ty =
       | tyConName tc == typeErrorVAppendDataConName ->
         pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2
 
-    -- An uneavaluated type function
+    -- An unevaluated type function
     _ -> ppr ty
 
 
@@ -882,7 +922,7 @@ pprUserTypeErrorTy ty =
 Note [Representation of function types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-Functions (e.g. Int -> Char) are can be thought of as being applications
+Functions (e.g. Int -> Char) can be thought of as being applications
 of funTyCon (known in Haskell surface syntax as (->)),
 
     (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
@@ -943,26 +983,25 @@ funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
 funArgTy (FunTy arg _res) = arg
 funArgTy ty               = pprPanic "funArgTy" (ppr ty)
 
-piResultTy :: Type -> Type ->  Type
+-- ^ Just like 'piResultTys' but for a single argument
+-- Try not to iterate 'piResultTy', because it's inefficient to substitute
+-- one variable at a time; instead use 'piResultTys"
+piResultTy :: HasDebugCallStack => Type -> Type ->  Type
 piResultTy ty arg = case piResultTy_maybe ty arg of
                       Just res -> res
                       Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)
 
 piResultTy_maybe :: Type -> Type -> Maybe Type
-
--- ^ Just like 'piResultTys' but for a single argument
--- Try not to iterate 'piResultTy', because it's inefficient to substitute
--- one variable at a time; instead use 'piResultTys"
 piResultTy_maybe ty arg
   | Just ty' <- coreView ty = piResultTy_maybe ty' arg
 
   | FunTy _ res <- ty
   = Just res
 
-  | ForAllTy (TvBndr tv _) res <- ty
+  | ForAllTy (Bndr tv _) res <- ty
   = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
                       tyCoVarsOfTypes [arg,res]
-    in Just (substTy (extendTvSubst empty_subst tv arg) res)
+    in Just (substTy (extendTCvSubst empty_subst tv arg) res)
 
   | otherwise
   = Nothing
@@ -988,7 +1027,7 @@ piResultTy_maybe ty arg
 -- so we pay attention to efficiency, especially in the special case
 -- where there are no for-alls so we are just dropping arrows from
 -- a function type/kind.
-piResultTys :: Type -> [Type] -> Type
+piResultTys :: HasDebugCallStack => Type -> [Type] -> Type
 piResultTys ty [] = ty
 piResultTys ty orig_args@(arg:args)
   | Just ty' <- coreView ty
@@ -997,34 +1036,39 @@ piResultTys ty orig_args@(arg:args)
   | FunTy _ res <- ty
   = piResultTys res args
 
-  | ForAllTy (TvBndr tv _) res <- ty
-  = go (extendVarEnv emptyTvSubstEnv tv arg) res args
+  | ForAllTy (Bndr tv _) res <- ty
+  = go (extendTCvSubst init_subst tv arg) res args
 
   | otherwise
   = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)
   where
-    in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))
+    init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))
 
-    go :: TvSubstEnv -> Type -> [Type] -> Type
-    go tv_env ty [] = substTy (mkTvSubst in_scope tv_env) ty
+    go :: TCvSubst -> Type -> [Type] -> Type
+    go subst ty [] = substTy subst ty
 
-    go tv_env ty all_args@(arg:args)
+    go subst ty all_args@(arg:args)
       | Just ty' <- coreView ty
-      = go tv_env ty' all_args
+      = go subst ty' all_args
 
       | FunTy _ res <- ty
-      = go tv_env res args
+      = go subst res args
 
-      | ForAllTy (TvBndr tv _) res <- ty
-      = go (extendVarEnv tv_env tv arg) res args
+      | ForAllTy (Bndr tv _) res <- ty
+      = go (extendTCvSubst subst tv arg) res args
 
-      | TyVarTy tv <- ty
-      , Just ty' <- lookupVarEnv tv_env tv
-        -- Deals with piResultTys (forall a. a) [forall b.b, Int]
-      = piResultTys ty' all_args
+      | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]
+      = go init_subst
+          (substTy subst ty)
+          all_args
 
       | otherwise
-      = pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
+      = -- We have not run out of arguments, but the function doesn't
+        -- have the right kind to apply to them; so panic.
+        -- Without the explicit isEmptyVarEnv test, an ill-kinded type
+        -- would give an infniite loop, which is very unhelpful
+        -- c.f. Trac #15473
+        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)
 
 applyTysX :: [TyVar] -> Type -> [Type] -> Type
 -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
@@ -1038,7 +1082,35 @@ applyTysX tvs body_ty arg_tys
     pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]
     n_tvs = length tvs
 
-{-
+
+
+{- Note [Care with kind instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  T :: forall k. k
+and we are finding the kind of
+  T (forall b. b -> b) * Int
+Then
+  T (forall b. b->b) :: k[ k :-> forall b. b->b]
+                     :: forall b. b -> b
+So
+  T (forall b. b->b) * :: (b -> b)[ b :-> *]
+                       :: * -> *
+
+In other words we must intantiate the forall!
+
+Similarly (Trac #15428)
+   S :: forall k f. k -> f k
+and we are finding the kind of
+   S * (* ->) Int Bool
+We have
+   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]
+              :: * -> * -> *
+So again we must instantiate.
+
+The same thing happens in ToIface.toIfaceAppArgsX.
+
+
 ---------------------------------------------------------------------
                                 TyConApp
                                 ~~~~~~~~
@@ -1085,7 +1157,7 @@ tyConAppArgs_maybe (FunTy arg res)
   | Just rep1 <- getRuntimeRep_maybe arg
   , Just rep2 <- getRuntimeRep_maybe res
   = Just [rep1, rep2, arg, res]
-tyConAppArgs_maybe _                = Nothing
+tyConAppArgs_maybe _  = Nothing
 
 tyConAppArgs :: Type -> [Type]
 tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
@@ -1116,12 +1188,9 @@ splitTyConApp_maybe ty                           = repSplitTyConApp_maybe ty
 repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
 repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 repSplitTyConApp_maybe (FunTy arg res)
-  | Just rep1 <- getRuntimeRep_maybe arg
-  , Just rep2 <- getRuntimeRep_maybe res
-  = Just (funTyCon, [rep1, rep2, arg, res])
-  | otherwise
-  = pprPanic "repSplitTyConApp_maybe"
-             (ppr arg $$ ppr res $$ ppr (typeKind res))
+  | Just arg_rep <- getRuntimeRep_maybe arg
+  , Just res_rep <- getRuntimeRep_maybe res
+  = Just (funTyCon, [arg_rep, res_rep, arg, res])
 repSplitTyConApp_maybe _ = Nothing
 
 -- | Attempts to tease a list type apart and gives the type of the elements if
@@ -1131,10 +1200,6 @@ splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of
   Just (tc,[e]) | tc == listTyCon -> Just e
   _other                          -> Nothing
 
--- | What is the role assigned to the next parameter of this type? Usually,
--- this will be 'Nominal', but if the type is a 'TyConApp', we may be able to
--- do better. The type does *not* have to be well-kinded when applied for this
--- to work!
 nextRole :: Type -> Role
 nextRole ty
   | Just (tc, tys) <- splitTyConApp_maybe ty
@@ -1161,47 +1226,21 @@ newTyConInstRhs tycon tys
                            ~~~~~~
 A casted type has its *kind* casted into something new.
 
-Note [No reflexive casts in types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As far as possible, we would like to maintain the following property:
-
-  (*) If (t1 `eqType` t2), then t1 and t2 are treated identically within GHC.
-
-The (*) property is very useful, because we have a tendency to compare two
-types to see if they're equal, and then arbitrarily choose one. We don't
-want this arbitrary choice to then matter later on. Maintaining (*) means
-that every function that looks at a structure of a type must think about
-casts. In places where we directly pattern-match, this consideration is
-forced by consideration of the CastTy constructor.
-
-But, when we call a splitXXX function, it's easy to ignore the possibility
-of casts. In particular, splitTyConApp is used extensively, and we don't
-want it to fail on (T a b c |> co). Happily, if we have
-  (T a b c |> co) `eqType` (T d e f)
-then co must be reflexive. Why? eqType checks that the kinds are equal, as
-well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).
-By the kind check, we know that (T a b c |> co) and (T d e f) have the same
-kind. So the only way that co could be non-reflexive is for (T a b c) to have
-a different kind than (T d e f). But because T's kind is closed (all tycon kinds
-are closed), the only way for this to happen is that one of the arguments has
-to differ, leading to a contradiction. Thus, co is reflexive.
-
-Accordingly, by eliminating reflexive casts, splitTyConApp need not worry
-about outermost casts to uphold (*).
-
-Unforunately, that's not the end of the story. Consider comparing
-  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> sym co)
-These two types have the same kind (Type), but the left type is a TyConApp
-while the right type is not. To handle this case, we will have to implement
-some variant of the dreaded KPush algorithm (c.f. CoreOpt.pushCoDataCon).
-This stone is left unturned for now, meaning that we don't yet uphold (*).
-
-The other place where (*) will be hard to guarantee is in splitAppTy, because
-I (Richard E) can't think of a way to push coercions into AppTys. The good
-news here is that splitAppTy is not used all that much, and so all clients of
-that function can simply be told to use splitCastTy as well, in order to
-uphold (*). This, too, is left undone, for now.
+Note [Weird typing rule for ForAllTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is the (truncated) typing rule for the dependent ForAllTy:
 
+inner : kind
+------------------------------------
+ForAllTy (Bndr tyvar vis) inner : kind
+
+inner : TYPE r
+------------------------------------
+ForAllTy (Bndr covar vis) inner : TYPE
+
+Note that when inside the binder is a tyvar, neither the inner type nor for
+ForAllTy itself have to have kind *! But, it means that we should push any kind
+casts through the ForAllTy. The only trouble is avoiding capture.
 -}
 
 splitCastTy_maybe :: Type -> Maybe (Type, Coercion)
@@ -1211,24 +1250,39 @@ splitCastTy_maybe _                            = Nothing
 
 -- | Make a 'CastTy'. The Coercion must be nominal. Checks the
 -- Coercion for reflexivity, dropping it if it's reflexive.
--- See Note [No reflexive casts in types]
+-- See Note [Respecting definitional equality] in TyCoRep
 mkCastTy :: Type -> Coercion -> Type
-mkCastTy ty co | isReflexiveCo co = ty
+mkCastTy ty co | isReflexiveCo co = ty  -- (EQ2) from the Note
 -- NB: Do the slow check here. This is important to keep the splitXXX
 -- functions working properly. Otherwise, we may end up with something
 -- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)
 -- fails under splitFunTy_maybe. This happened with the cheaper check
 -- in test dependent/should_compile/dynamic-paper.
 
-mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2)
+mkCastTy (CastTy ty co1) co2
+  -- (EQ3) from the Note
+  = mkCastTy ty (co1 `mkTransCo` co2)
+      -- call mkCastTy again for the reflexivity check
+
+mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co
+  -- (EQ4) from the Note
+  | isTyVar tv
+  , let fvs = tyCoVarsOfCo co
+  = -- have to make sure that pushing the co in doesn't capture the bound var!
+    if tv `elemVarSet` fvs
+    then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs)
+             (subst, tv') = substVarBndr empty_subst tv
+         in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co)
+    else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co)
+
 mkCastTy ty co = CastTy ty co
 
-tyConBindersTyBinders :: [TyConBinder] -> [TyBinder]
--- Return the tyConBinders in TyBinder form
-tyConBindersTyBinders = map to_tyb
+tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]
+-- Return the tyConBinders in TyCoBinder form
+tyConBindersTyCoBinders = map to_tyb
   where
-    to_tyb (TvBndr tv (NamedTCB vis)) = Named (TvBndr tv vis)
-    to_tyb (TvBndr tv AnonTCB)        = Anon (tyVarKind tv)
+    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)
+    to_tyb (Bndr tv AnonTCB)        = Anon (varType tv)
 
 {-
 --------------------------------------------------------------------
@@ -1280,26 +1334,40 @@ interfaces.  Notably this plays a role in tcTySigs in TcBinds.hs.
 
 -- | Make a dependent forall over an Inferred (as opposed to Specified)
 -- variable
+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type
+mkTyCoInvForAllTy tv ty
+  | isCoVar tv
+  , not (tv `elemVarSet` tyCoVarsOfType ty)
+  = mkFunTy (varType tv) ty
+  | otherwise
+  = ForAllTy (Bndr tv Inferred) ty
+
+-- | Like mkTyCoInvForAllTy, but tv should be a tyvar
 mkInvForAllTy :: TyVar -> Type -> Type
 mkInvForAllTy tv ty = ASSERT( isTyVar tv )
-                      ForAllTy (TvBndr tv Inferred) ty
+                      ForAllTy (Bndr tv Inferred) ty
 
 -- | Like mkForAllTys, but assumes all variables are dependent and Inferred,
 -- a common case
+mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type
+mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs
+
+-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar
 mkInvForAllTys :: [TyVar] -> Type -> Type
-mkInvForAllTys tvs ty = ASSERT( all isTyVar tvs )
-                        foldr mkInvForAllTy ty tvs
+mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs
 
 -- | Like mkForAllTys, but assumes all variables are dependent and specified,
 -- a common case
 mkSpecForAllTys :: [TyVar] -> Type -> Type
 mkSpecForAllTys tvs = ASSERT( all isTyVar tvs )
-                     mkForAllTys [ TvBndr tv Specified | tv <- tvs ]
+                      -- covar is always Inferred, so all inputs should be tyvar
+                      mkForAllTys [ Bndr tv Specified | tv <- tvs ]
 
 -- | Like mkForAllTys, but assumes all variables are dependent and visible
 mkVisForAllTys :: [TyVar] -> Type -> Type
 mkVisForAllTys tvs = ASSERT( all isTyVar tvs )
-                     mkForAllTys [ TvBndr tv Required | tv <- tvs ]
+                     -- covar is always Inferred, so all inputs should be tyvar
+                     mkForAllTys [ Bndr tv Required | tv <- tvs ]
 
 mkLamType  :: Var -> Type -> Type
 -- ^ Makes a @(->)@ type or an implicit forall type, depending
@@ -1310,46 +1378,67 @@ mkLamTypes :: [Var] -> Type -> Type
 -- ^ 'mkLamType' for multiple type or value arguments
 
 mkLamType v ty
-   | isTyVar v = ForAllTy (TvBndr v Inferred) ty
-   | otherwise = FunTy    (varType v)          ty
+   | isCoVar v
+   , v `elemVarSet` tyCoVarsOfType ty
+   = ForAllTy (Bndr v Inferred) ty
+   | isTyVar v
+   = ForAllTy (Bndr v Inferred) ty
+   | otherwise
+   = FunTy (varType v) ty
 
 mkLamTypes vs ty = foldr mkLamType ty vs
 
--- | Given a list of type-level vars and a result type, makes TyBinders, preferring
--- anonymous binders if the variable is, in fact, not dependent.
--- All binders are /visible/.
+-- | Given a list of type-level vars and a result kind,
+-- makes TyCoBinders, preferring anonymous binders
+-- if the variable is, in fact, not dependent.
+-- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)
+-- We want (k:*) Named, (b:k) Anon, (c:k) Anon
+--
+-- All non-coercion binders are /visible/.
 mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder]
-mkTyConBindersPreferAnon vars inner_ty = fst (go vars)
+mkTyConBindersPreferAnon vars inner_ty = ASSERT( all isTyVar vars)
+                                               fst (go vars)
   where
     go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars
     go [] = ([], tyCoVarsOfType inner_ty)
-    go (v:vs) |  v `elemVarSet` fvs
-              = ( TvBndr v (NamedTCB Required) : binders
+    go (v:vs) | v `elemVarSet` fvs
+              = ( Bndr v (NamedTCB Required) : binders
                 , fvs `delVarSet` v `unionVarSet` kind_vars )
               | otherwise
-              = ( TvBndr v AnonTCB : binders
+              = ( Bndr v AnonTCB : binders
                 , fvs `unionVarSet` kind_vars )
       where
         (binders, fvs) = go vs
         kind_vars      = tyCoVarsOfType $ tyVarKind v
 
--- | Take a ForAllTy apart, returning the list of tyvars and the result type.
+-- | Take a ForAllTy apart, returning the list of tycovars and the result type.
 -- This always succeeds, even if it returns only an empty list. Note that the
 -- result type returned may have free variables that were bound by a forall.
-splitForAllTys :: Type -> ([TyVar], Type)
+splitForAllTys :: Type -> ([TyCoVar], Type)
 splitForAllTys ty = split ty ty []
   where
     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
-    split _       (ForAllTy (TvBndr tv _) ty) tvs = split ty ty (tv:tvs)
-    split orig_ty _                           tvs = (reverse tvs, orig_ty)
+    split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)
+    split orig_ty _                            tvs = (reverse tvs, orig_ty)
+
+-- | Like splitForAllTys, but split only for tyvars.
+-- This always succeeds, even if it returns only an empty list. Note that the
+-- result type returned may have free variables that were bound by a forall.
+splitTyVarForAllTys :: Type -> ([TyVar], Type)
+splitTyVarForAllTys ty = split ty ty []
+  where
+    split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs
+    split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)
+    split orig_ty _                   tvs              = (reverse tvs, orig_ty)
 
 -- | Like 'splitPiTys' but split off only /named/ binders.
-splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type)
-splitForAllTyVarBndrs ty = split ty ty []
+splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)
+splitForAllVarBndrs ty = split ty ty []
   where
     split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
-    split _       (ForAllTy b res) bs  = split res res (b:bs)
-    split orig_ty _                bs  = (reverse bs, orig_ty)
+    split _       (ForAllTy b res) bs = split res res (b:bs)
+    split orig_ty _                bs = (reverse bs, orig_ty)
+{-# INLINE splitForAllVarBndrs #-}
 
 -- | Checks whether this is a proper forall (with a named binder)
 isForAllTy :: Type -> Bool
@@ -1357,6 +1446,18 @@ isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty'
 isForAllTy (ForAllTy {}) = True
 isForAllTy _             = False
 
+-- | Like `isForAllTy`, but returns True only if it is a tyvar binder
+isForAllTy_ty :: Type -> Bool
+isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty'
+isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True
+isForAllTy_ty _             = False
+
+-- | Like `isForAllTy`, but returns True only if it is a covar binder
+isForAllTy_co :: Type -> Bool
+isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty'
+isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True
+isForAllTy_co _             = False
+
 -- | Is this a function or forall?
 isPiTy :: Type -> Bool
 isPiTy ty | Just ty' <- coreView ty = isForAllTy ty'
@@ -1365,7 +1466,7 @@ isPiTy (FunTy {})    = True
 isPiTy _             = False
 
 -- | Take a forall type apart, or panics if that is not possible.
-splitForAllTy :: Type -> (TyVar, Type)
+splitForAllTy :: Type -> (TyCoVar, Type)
 splitForAllTy ty
   | Just answer <- splitForAllTy_maybe ty = answer
   | otherwise                             = pprPanic "splitForAllTy" (ppr ty)
@@ -1380,16 +1481,32 @@ dropForAlls ty = go ty
 
 -- | Attempts to take a forall type apart, but only if it's a proper forall,
 -- with a named binder
-splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
+splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)
 splitForAllTy_maybe ty = go ty
   where
     go ty | Just ty' <- coreView ty = go ty'
-    go (ForAllTy (TvBndr tv _) ty) = Just (tv, ty)
-    go _                           = Nothing
+    go (ForAllTy (Bndr tv _) ty)    = Just (tv, ty)
+    go _                            = Nothing
+
+-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder.
+splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)
+splitForAllTy_ty_maybe ty = go ty
+  where
+    go ty | Just ty' <- coreView ty = go ty'
+    go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty)
+    go _                            = Nothing
+
+-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder.
+splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)
+splitForAllTy_co_maybe ty = go ty
+  where
+    go ty | Just ty' <- coreView ty = go ty'
+    go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty)
+    go _                            = Nothing
 
 -- | Attempts to take a forall type apart; works with proper foralls and
 -- functions
-splitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
+splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type)
 splitPiTy_maybe ty = go ty
   where
     go ty | Just ty' <- coreView ty = go ty'
@@ -1398,28 +1515,30 @@ splitPiTy_maybe ty = go ty
     go _                  = Nothing
 
 -- | Takes a forall type apart, or panics
-splitPiTy :: Type -> (TyBinder, Type)
+splitPiTy :: Type -> (TyCoBinder, Type)
 splitPiTy ty
   | Just answer <- splitPiTy_maybe ty = answer
   | otherwise                         = pprPanic "splitPiTy" (ppr ty)
 
--- | Split off all TyBinders to a type, splitting both proper foralls
+-- | Split off all TyCoBinders to a type, splitting both proper foralls
 -- and functions
-splitPiTys :: Type -> ([TyBinder], Type)
-splitPiTys ty = split ty ty []
+splitPiTys :: Type -> ([TyCoBinder], Type)
+splitPiTys ty = split ty ty
   where
-    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
-    split _       (ForAllTy b res) bs  = split res res (Named b  : bs)
-    split _       (FunTy arg res)  bs  = split res res (Anon arg : bs)
-    split orig_ty _                bs  = (reverse bs, orig_ty)
+    split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
+    split _       (ForAllTy b res) = let (bs, ty) = split res res
+                                     in  (Named b : bs, ty)
+    split _       (FunTy arg res)  = let (bs, ty) = split res res
+                                     in  (Anon arg : bs, ty)
+    split orig_ty _                = ([], orig_ty)
 
 -- Like splitPiTys, but returns only *invisible* binders, including constraints
 -- Stops at the first visible binder
-splitPiTysInvisible :: Type -> ([TyBinder], Type)
+splitPiTysInvisible :: Type -> ([TyCoBinder], Type)
 splitPiTysInvisible ty = split ty ty []
    where
     split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
-    split _       (ForAllTy b@(TvBndr _ vis) res) bs
+    split _       (ForAllTy b@(Bndr _ vis) res) bs
       | isInvisibleArgFlag vis         = split res res (Named b  : bs)
     split _       (FunTy arg res)  bs
       | isPredTy arg                   = split res res (Anon arg : bs)
@@ -1427,11 +1546,12 @@ splitPiTysInvisible ty = split ty ty []
 
 -- | Given a tycon and its arguments, filters out any invisible arguments
 filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]
-filterOutInvisibleTypes tc tys = snd $ partitionInvisibles tc id tys
+filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys
 
--- | Like 'filterOutInvisibles', but works on 'TyVar's
-filterOutInvisibleTyVars :: TyCon -> [TyVar] -> [TyVar]
-filterOutInvisibleTyVars tc tvs = snd $ partitionInvisibles tc mkTyVarTy tvs
+-- | Given a 'TyCon' and its arguments, partition the arguments into
+-- (invisible arguments, visible arguments).
+partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
+partitionInvisibleTypes tc tys = partitionInvisibles tc id tys
 
 -- | Given a tycon and a list of things (which correspond to arguments),
 -- partitions the things into
@@ -1456,11 +1576,11 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])
 partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc)
   where
     go _ _ [] = ([], [])
-    go subst (ForAllTy (TvBndr tv vis) res_ki) (x:xs)
+    go subst (ForAllTy (Bndr tv vis) res_ki) (x:xs)
       | isVisibleArgFlag vis = second (x :) (go subst' res_ki xs)
       | otherwise            = first  (x :) (go subst' res_ki xs)
       where
-        subst' = extendTvSubst subst tv (get_ty x)
+        subst' = extendTCvSubst subst tv (get_ty x)
     go subst (TyVarTy tv) xs
       | Just ki <- lookupTyVar subst tv = go subst ki xs
     go _ _ xs = ([], xs)  -- something is ill-kinded. But this can happen
@@ -1481,60 +1601,53 @@ isTauTy (CoercionTy _)        = False  -- Not sure about this
 {-
 %************************************************************************
 %*                                                                      *
-   TyBinders
+   TyCoBinders
 %*                                                                      *
 %************************************************************************
 -}
 
--- | Make a named binder
-mkTyVarBinder :: ArgFlag -> Var -> TyVarBinder
-mkTyVarBinder vis var = TvBndr var vis
-
--- | Make many named binders
-mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder]
-mkTyVarBinders vis = map (mkTyVarBinder vis)
-
 -- | Make an anonymous binder
-mkAnonBinder :: Type -> TyBinder
+mkAnonBinder :: Type -> TyCoBinder
 mkAnonBinder = Anon
 
 -- | Does this binder bind a variable that is /not/ erased? Returns
 -- 'True' for anonymous binders.
-isAnonTyBinder :: TyBinder -> Bool
-isAnonTyBinder (Named {}) = False
-isAnonTyBinder (Anon {})  = True
+isAnonTyCoBinder :: TyCoBinder -> Bool
+isAnonTyCoBinder (Named {}) = False
+isAnonTyCoBinder (Anon {})  = True
 
-isNamedTyBinder :: TyBinder -> Bool
-isNamedTyBinder (Named {}) = True
-isNamedTyBinder (Anon {})  = False
+isNamedTyCoBinder :: TyCoBinder -> Bool
+isNamedTyCoBinder (Named {}) = True
+isNamedTyCoBinder (Anon {})  = False
 
-tyBinderType :: TyBinder -> Type
+tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar
+tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv
+tyCoBinderVar_maybe _          = Nothing
+
+tyCoBinderType :: TyCoBinder -> Type
 -- Barely used
-tyBinderType (Named tvb) = binderKind tvb
+tyCoBinderType (Named tvb) = binderType tvb
+tyCoBinderType (Anon ty)   = ty
+
+tyBinderType :: TyBinder -> Type
+tyBinderType (Named (Bndr tv _))
+  = ASSERT( isTyVar tv )
+    tyVarKind tv
 tyBinderType (Anon ty)   = ty
 
 -- | Extract a relevant type, if there is one.
-binderRelevantType_maybe :: TyBinder -> Maybe Type
+binderRelevantType_maybe :: TyCoBinder -> Maybe Type
 binderRelevantType_maybe (Named {}) = Nothing
 binderRelevantType_maybe (Anon ty)  = Just ty
 
 -- | Like 'maybe', but for binders.
-caseBinder :: TyBinder           -- ^ binder to scrutinize
-           -> (TyVarBinder -> a) -- ^ named case
-           -> (Type -> a)        -- ^ anonymous case
+caseBinder :: TyCoBinder           -- ^ binder to scrutinize
+           -> (TyCoVarBinder -> a) -- ^ named case
+           -> (Type -> a)          -- ^ anonymous case
            -> a
 caseBinder (Named v) f _ = f v
 caseBinder (Anon t)  _ d = d t
 
--- | Manufacture a new 'TyConBinder' from a 'TyBinder'. Anonymous
--- 'TyBinder's are still assigned names as 'TyConBinder's, so we need
--- the extra gunk with which to construct a 'Name'. Used when producing
--- tyConTyVars from a datatype kind signature. Defined here to avoid module
--- loops.
-mkTyBinderTyConBinder :: TyBinder -> SrcSpan -> Unique -> OccName -> TyConBinder
-mkTyBinderTyConBinder (Named (TvBndr tv argf)) _ _ _ = TvBndr tv (NamedTCB argf)
-mkTyBinderTyConBinder (Anon kind) loc uniq occ
-  = TvBndr (mkTyVar (mkInternalName uniq occ loc) kind) AnonTCB
 
 {-
 %************************************************************************
@@ -1567,6 +1680,56 @@ But there are a number of complications:
   want to print it nicely in error messages.
 -}
 
+-- | Split a type constructor application into its type constructor and
+-- applied types. Note that this may fail in the case of a 'FunTy' with an
+-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind
+-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your
+-- type before using this function.
+--
+-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.
+tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
+-- Defined here to avoid module loops between Unify and TcType.
+tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
+tcSplitTyConApp_maybe ty                         = tcRepSplitTyConApp_maybe ty
+
+-- tcIsConstraintKind stuf only makes sense in the typechecker
+-- After that Constraint = Type
+-- See Note [coreView vs tcView]
+-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh)
+tcIsConstraintKind :: Kind -> Bool
+tcIsConstraintKind ty
+  | Just (tc, args) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here
+  , isConstraintKindCon tc
+  = ASSERT2( null args, ppr ty ) True
+
+  | otherwise
+  = False
+
+-- | Is this kind equivalent to @*@?
+--
+-- This considers 'Constraint' to be distinct from @*@. For a version that
+-- treats them as the same type, see 'isLiftedTypeKind'.
+tcIsLiftedTypeKind :: Kind -> Bool
+tcIsLiftedTypeKind ty
+  | Just (type_tc, [arg]) <- tcSplitTyConApp_maybe ty
+  , type_tc `hasKey` tYPETyConKey
+  , Just (lifted_rep_tc, args) <- tcSplitTyConApp_maybe arg
+  , lifted_rep_tc `hasKey` liftedRepDataConKey
+  = ASSERT2( null args, ppr ty ) True
+  | otherwise
+  = False
+
+tcReturnsConstraintKind :: Kind -> Bool
+-- True <=> the Kind ultimately returns a Constraint
+--   E.g.  * -> Constraint
+--         forall k. k -> Constraint
+tcReturnsConstraintKind kind
+  | Just kind' <- tcView kind = tcReturnsConstraintKind kind'
+tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty
+tcReturnsConstraintKind (FunTy    _ ty) = tcReturnsConstraintKind ty
+tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc
+tcReturnsConstraintKind _               = False
+
 -- | Is the type suitable to classify a given/wanted in the typechecker?
 isPredTy :: Type -> Bool
 -- See Note [isPredTy complications]
@@ -1594,7 +1757,7 @@ isPredTy ty = go ty []
 
     go_k :: Kind -> [KindOrType] -> Bool
     -- True <=> ('k' applied to 'kts') = Constraint
-    go_k k [] = isConstraintKind k
+    go_k k [] = tcIsConstraintKind k
     go_k k (arg:args) = case piResultTy_maybe k arg of
                           Just k' -> go_k k' args
                           Nothing -> WARN( True, text "isPredTy" <+> ppr ty )
@@ -1769,20 +1932,36 @@ eqRelRole :: EqRel -> Role
 eqRelRole NomEq  = Nominal
 eqRelRole ReprEq = Representational
 
-data PredTree = ClassPred Class [Type]
-              | EqPred EqRel Type Type
-              | IrredPred PredType
+data PredTree
+  = ClassPred Class [Type]
+  | EqPred EqRel Type Type
+  | IrredPred PredType
+  | ForAllPred [TyCoVarBinder] [PredType] PredType
+     -- ForAllPred: see Note [Quantified constraints] in TcCanonical
+  -- NB: There is no TuplePred case
+  --     Tuple predicates like (Eq a, Ord b) are just treated
+  --     as ClassPred, as if we had a tuple class with two superclasses
+  --        class (c1, c2) => (%,%) c1 c2
 
 classifyPredType :: PredType -> PredTree
 classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
     Just (tc, [_, _, ty1, ty2])
-      | tc `hasKey` eqReprPrimTyConKey    -> EqPred ReprEq ty1 ty2
-      | tc `hasKey` eqPrimTyConKey        -> EqPred NomEq ty1 ty2
+      | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2
+      | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq ty1 ty2
+
     Just (tc, tys)
-      | Just clas <- tyConClass_maybe tc  -> ClassPred clas tys
-    _                                     -> IrredPred ev_ty
+      | Just clas <- tyConClass_maybe tc
+      -> ClassPred clas tys
+
+    _ | (tvs, rho) <- splitForAllVarBndrs ev_ty
+      , (theta, pred) <- splitFunTys rho
+      , not (null tvs && null theta)
+      -> ForAllPred tvs theta pred
 
-getClassPredTys :: PredType -> (Class, [Type])
+      | otherwise
+      -> IrredPred ev_ty
+
+getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
 getClassPredTys ty = case getClassPredTys_maybe ty of
         Just (clas, tys) -> (clas, tys)
         Nothing          -> pprPanic "getClassPredTys" (ppr ty)
@@ -1836,7 +2015,12 @@ predTypeEqRel ty
 --
 -- This is a deterministic sorting operation
 -- (that is, doesn't depend on Uniques).
-toposortTyVars :: [TyVar] -> [TyVar]
+--
+-- It is also meant to be stable: that is, variables should not
+-- be reordered unnecessarily. The implementation of this
+-- has been observed to be stable, though it is not proven to
+-- be so. See also Note [Ordering of implicit variables] in RnTypes
+toposortTyVars :: [TyCoVar] -> [TyCoVar]
 toposortTyVars tvs = reverse $
                      [ node_payload node | node <- topologicalSortG $
                                           graphFromEdgedVerticesOrd nodes ]
@@ -1915,7 +2099,6 @@ pprSourceTyCon tycon
   | otherwise
   = ppr tycon
 
--- @isTauTy@ tests if a type has no foralls
 isFamFreeTy :: Type -> Bool
 isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'
 isFamFreeTy (TyVarTy _)       = True
@@ -1940,7 +2123,7 @@ isFamFreeTy (CoercionTy _)    = False  -- Not sure about this
 -- levity polymorphic), and panics if the kind does not have the shape
 -- TYPE r.
 isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool
-isLiftedType_maybe ty = go (getRuntimeRep "isLiftedType_maybe" ty)
+isLiftedType_maybe ty = go (getRuntimeRep ty)
   where
     go rr | Just rr' <- coreView rr = go rr'
     go (TyConApp lifted_rep [])
@@ -1960,6 +2143,19 @@ isUnliftedType ty
   = not (isLiftedType_maybe ty `orElse`
          pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)))
 
+-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)
+isRuntimeRepKindedTy :: Type -> Bool
+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind
+
+-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.
+-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:
+--
+--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep
+--                      , String, Int# ] == [String, Int#]
+--
+dropRuntimeRepArgs :: [Type] -> [Type]
+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy
+
 -- | Extract the RuntimeRep classifier of a type. For instance,
 -- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not
 -- possible.
@@ -1969,24 +2165,21 @@ getRuntimeRep_maybe = getRuntimeRepFromKind_maybe . typeKind
 
 -- | Extract the RuntimeRep classifier of a type. For instance,
 -- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.
-getRuntimeRep :: HasDebugCallStack
-              => String   -- ^ Printed in case of an error
-              -> Type -> Type
-getRuntimeRep err ty =
-    case getRuntimeRep_maybe ty of
+getRuntimeRep :: HasDebugCallStack => Type -> Type
+getRuntimeRep ty
+  = case getRuntimeRep_maybe ty of
       Just r  -> r
-      Nothing -> pprPanic "getRuntimeRep"
-                          (text err $$ ppr ty <+> dcolon <+> ppr (typeKind ty))
+      Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))
 
 -- | Extract the RuntimeRep classifier of a type from its kind. For example,
 -- @getRuntimeRepFromKind * = LiftedRep@; Panics if this is not possible.
 getRuntimeRepFromKind :: HasDebugCallStack
-                      => String -> Type -> Type
-getRuntimeRepFromKind err k =
+                      => Type -> Type
+getRuntimeRepFromKind k =
     case getRuntimeRepFromKind_maybe k of
       Just r  -> r
       Nothing -> pprPanic "getRuntimeRepFromKind"
-                          (text err $$ ppr k <+> dcolon <+> ppr (typeKind k))
+                           (ppr k <+> dcolon <+> ppr (typeKind k))
 
 -- | Extract the RuntimeRep classifier of a type from its kind. For example,
 -- @getRuntimeRepFromKind * = LiftedRep@; Returns 'Nothing' if this is not
@@ -2004,14 +2197,14 @@ getRuntimeRepFromKind_maybe = go
 
 isUnboxedTupleType :: Type -> Bool
 isUnboxedTupleType ty
-  = tyConAppTyCon (getRuntimeRep "isUnboxedTupleType" ty) `hasKey` tupleRepDataConKey
+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey
   -- NB: Do not use typePrimRep, as that can't tell the difference between
   -- unboxed tuples and unboxed sums
 
 
 isUnboxedSumType :: Type -> Bool
 isUnboxedSumType ty
-  = tyConAppTyCon (getRuntimeRep "isUnboxedSumType" ty) `hasKey` sumRepDataConKey
+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey
 
 -- | See "Type#type_classification" for what an algebraic type is.
 -- Should only be applied to /types/, as opposed to e.g. partially
@@ -2023,17 +2216,6 @@ isAlgType ty
                             isAlgTyCon tc
       _other             -> False
 
--- | See "Type#type_classification" for what an algebraic type is.
--- Should only be applied to /types/, as opposed to e.g. partially
--- saturated type constructors. Closed type constructors are those
--- with a fixed right hand side, as opposed to e.g. associated types
-isClosedAlgType :: Type -> Bool
-isClosedAlgType ty
-  = case splitTyConApp_maybe ty of
-      Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
-      _other -> False
-
 -- | Check whether a type is a data family type
 isDataFamilyAppType :: Type -> Bool
 isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of
@@ -2090,7 +2272,39 @@ isValidJoinPointType arity ty
       | otherwise
       = False
 
-{-
+{- Note [Excess polymorphism and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In principle, if a function would be a join point except that it fails
+the polymorphism rule (see Note [The polymorphism rule of join points] in
+CoreSyn), it can still be made a join point with some effort. This is because
+all tail calls must return the same type (they return to the same context!), and
+thus if the return type depends on an argument, that argument must always be the
+same.
+
+For instance, consider:
+
+  let f :: forall a. a -> Char -> [a]
+      f @a x c = ... f @a y 'a' ...
+  in ... f @Int 1 'b' ... f @Int 2 'c' ...
+
+(where the calls are tail calls). `f` fails the polymorphism rule because its
+return type is [a], where [a] is bound. But since the type argument is always
+'Int', we can rewrite it as:
+
+  let f' :: Int -> Char -> [Int]
+      f' x c = ... f' y 'a' ...
+  in ... f' 1 'b' ... f 2 'c' ...
+
+and now we can make f' a join point:
+
+  join f' :: Int -> Char -> [Int]
+       f' x c = ... jump f' y 'a' ...
+  in ... jump f' 1 'b' ... jump f' 2 'c' ...
+
+It's not clear that this comes up often, however. TODO: Measure how often and
+add this analysis if necessary.  See Trac #14620.
+
+
 ************************************************************************
 *                                                                      *
 \subsection{Sequencing on types}
@@ -2104,7 +2318,7 @@ seqType (TyVarTy tv)                = tv `seq` ()
 seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2
 seqType (FunTy t1 t2)               = seqType t1 `seq` seqType t2
 seqType (TyConApp tc tys)           = tc `seq` seqTypes tys
-seqType (ForAllTy (TvBndr tv _) ty) = seqType (tyVarKind tv) `seq` seqType ty
+seqType (ForAllTy (Bndr tv _) ty)   = seqType (varType tv) `seq` seqType ty
 seqType (CastTy ty co)              = seqType ty `seq` seqCo co
 seqType (CoercionTy co)             = seqCo co
 
@@ -2165,7 +2379,7 @@ eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
 eqVarBndrs env [] []
  = Just env
 eqVarBndrs env (tv1:tvs1) (tv2:tvs2)
- | eqTypeX env (tyVarKind tv1) (tyVarKind tv2)
+ | eqTypeX env (varType tv1) (varType tv2)
  = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2
 eqVarBndrs _ _ _= Nothing
 
@@ -2245,8 +2459,8 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
 
     go env (TyVarTy tv1)       (TyVarTy tv2)
       = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2
-    go env (ForAllTy (TvBndr tv1 _) t1) (ForAllTy (TvBndr tv2 _) t2)
-      = go env (tyVarKind tv1) (tyVarKind tv2)
+    go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2)
+      = go env (varType tv1) (varType tv2)
         `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2
         -- See Note [Equality on AppTys]
     go env (AppTy s1 t1) ty2
@@ -2289,18 +2503,20 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
 nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
 nonDetCmpTypesX _   []        []        = EQ
 nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2
-                                      `thenCmp` nonDetCmpTypesX env tys1 tys2
+                                          `thenCmp`
+                                          nonDetCmpTypesX env tys1 tys2
 nonDetCmpTypesX _   []        _         = LT
 nonDetCmpTypesX _   _         []        = GT
 
 -------------
--- | Compare two 'TyCon's. NB: This should /never/ see the "star synonyms",
--- as recognized by Kind.isStarKindSynonymTyCon. See Note
--- [Kind Constraint and kind *] in Kind.
+-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as
+-- recognized by Kind.isConstraintKindCon) which is considered a synonym for
+-- 'Type' in Core.
+-- See Note [Kind Constraint and kind Type] in Kind.
 -- See Note [nonDetCmpType nondeterminism]
 nonDetCmpTc :: TyCon -> TyCon -> Ordering
 nonDetCmpTc tc1 tc2
-  = ASSERT( not (isStarKindSynonymTyCon tc1) && not (isStarKindSynonymTyCon tc2) )
+  = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )
     u1 `nonDetCmpUnique` u2
   where
     u1  = tyConUnique tc1
@@ -2314,16 +2530,34 @@ nonDetCmpTc tc1 tc2
 ************************************************************************
 -}
 
-typeKind :: Type -> Kind
-typeKind (TyConApp tc tys)     = piResultTys (tyConKind tc) tys
-typeKind (AppTy fun arg)       = piResultTy (typeKind fun) arg
-typeKind (LitTy l)             = typeLiteralKind l
-typeKind (FunTy {})            = liftedTypeKind
-typeKind (ForAllTy _ ty)       = typeKind ty
-typeKind (TyVarTy tyvar)       = tyVarKind tyvar
-typeKind (CastTy _ty co)       = pSnd $ coercionKind co
-typeKind (CoercionTy co)       = coercionType co
-
+typeKind :: HasDebugCallStack => Type -> Kind
+typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
+typeKind (AppTy fun arg)   = typeKind_apps fun [arg]
+typeKind (LitTy l)         = typeLiteralKind l
+typeKind (FunTy {})        = liftedTypeKind
+typeKind (TyVarTy tyvar)   = tyVarKind tyvar
+typeKind (CastTy _ty co)   = pSnd $ coercionKind co
+typeKind (CoercionTy co)   = coercionType co
+typeKind ty@(ForAllTy (Bndr tv _) _)
+  | isTyVar tv                     -- See Note [Weird typing rule for ForAllTy].
+  = case occCheckExpand tvs k of   -- We must make sure tv does not occur in kind
+      Just k' -> k'                -- As it is already out of scope!
+      Nothing -> pprPanic "typeKind"
+                  (ppr ty $$ ppr k $$ ppr tvs $$ ppr body)
+  where
+    (tvs, body) = splitTyVarForAllTys ty
+    k           = typeKind body
+typeKind (ForAllTy {})     = liftedTypeKind
+
+typeKind_apps :: HasDebugCallStack => Type -> [Type] -> Kind
+-- The sole purpose of the function is to accumulate
+-- the type arugments, so we can call piResultTys, rather than
+-- a succession of calls to piResultTy (which is asymptotically
+-- less efficient as the number of arguments increases)
+typeKind_apps (AppTy fun arg) args = typeKind_apps fun (arg:args)
+typeKind_apps fun             args = piResultTys (typeKind fun) args
+
+--------------------------
 typeLiteralKind :: TyLit -> Kind
 typeLiteralKind l =
   case l of
@@ -2354,6 +2588,160 @@ isTypeLevPoly = go
 resultIsLevPoly :: Type -> Bool
 resultIsLevPoly = isTypeLevPoly . snd . splitPiTys
 
+
+{- **********************************************************************
+*                                                                       *
+           Occurs check expansion
+%*                                                                      *
+%********************************************************************* -}
+
+{- Note [Occurs check expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid
+of occurrences of tv outside type function arguments, if that is
+possible; otherwise, it returns Nothing.
+
+For example, suppose we have
+  type F a b = [a]
+Then
+  occCheckExpand b (F Int b) = Just [Int]
+but
+  occCheckExpand a (F a Int) = Nothing
+
+We don't promise to do the absolute minimum amount of expanding
+necessary, but we try not to do expansions we don't need to.  We
+prefer doing inner expansions first.  For example,
+  type F a b = (a, Int, a, [a])
+  type G b   = Char
+We have
+  occCheckExpand b (F (G b)) = Just (F Char)
+even though we could also expand F to get rid of b.
+-}
+
+occCheckExpand :: [Var] -> Type -> Maybe Type
+-- See Note [Occurs check expansion]
+-- We may have needed to do some type synonym unfolding in order to
+-- get rid of the variable (or forall), so we also return the unfolded
+-- version of the type, which is guaranteed to be syntactically free
+-- of the given type variable.  If the type is already syntactically
+-- free of the variable, then the same type is returned.
+occCheckExpand vs_to_avoid ty
+  = go (mkVarSet vs_to_avoid, emptyVarEnv) ty
+  where
+    go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type
+          -- The VarSet is the set of variables we are trying to avoid
+          -- The VarEnv carries mappings necessary
+          -- because of kind expansion
+    go cxt@(as, env) (TyVarTy tv')
+      | tv' `elemVarSet` as               = Nothing
+      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')
+      | otherwise                         = do { tv'' <- go_var cxt tv'
+                                               ; return (mkTyVarTy tv'') }
+
+    go _   ty@(LitTy {}) = return ty
+    go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1
+                                ; ty2' <- go cxt ty2
+                                ; return (mkAppTy ty1' ty2') }
+    go cxt (FunTy ty1 ty2) = do { ty1' <- go cxt ty1
+                                ; ty2' <- go cxt ty2
+                                ; return (mkFunTy ty1' ty2') }
+    go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)
+       = do { ki' <- go cxt (varType tv)
+            ; let tv' = setVarType tv ki'
+                  env' = extendVarEnv env tv tv'
+                  as'  = as `delVarSet` tv
+            ; body' <- go (as', env') body_ty
+            ; return (ForAllTy (Bndr tv' vis) body') }
+
+    -- For a type constructor application, first try expanding away the
+    -- offending variable from the arguments.  If that doesn't work, next
+    -- see if the type constructor is a type synonym, and if so, expand
+    -- it and try again.
+    go cxt ty@(TyConApp tc tys)
+      = case mapM (go cxt) tys of
+          Just tys' -> return (mkTyConApp tc tys')
+          Nothing | Just ty' <- tcView ty -> go cxt ty'
+                  | otherwise             -> Nothing
+                      -- Failing that, try to expand a synonym
+
+    go cxt (CastTy ty co) =  do { ty' <- go cxt ty
+                                ; co' <- go_co cxt co
+                                ; return (mkCastTy ty' co') }
+    go cxt (CoercionTy co) = do { co' <- go_co cxt co
+                                ; return (mkCoercionTy co') }
+
+    ------------------
+    go_var cxt v = do { k' <- go cxt (varType v)
+                      ; return (setVarType v k') }
+           -- Works for TyVar and CoVar
+           -- See Note [Occurrence checking: look inside kinds]
+
+    ------------------
+    go_mco _   MRefl = return MRefl
+    go_mco ctx (MCo co) = MCo <$> go_co ctx co
+
+    ------------------
+    go_co cxt (Refl ty)                 = do { ty' <- go cxt ty
+                                             ; return (mkNomReflCo ty') }
+    go_co cxt (GRefl r ty mco)          = do { mco' <- go_mco cxt mco
+                                             ; ty' <- go cxt ty
+                                             ; return (mkGReflCo r ty' mco') }
+      -- Note: Coercions do not contain type synonyms
+    go_co cxt (TyConAppCo r tc args)    = do { args' <- mapM (go_co cxt) args
+                                             ; return (mkTyConAppCo r tc args') }
+    go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co
+                                             ; arg' <- go_co cxt arg
+                                             ; return (mkAppCo co' arg') }
+    go_co cxt@(as, env) (ForAllCo tv kind_co body_co)
+      = do { kind_co' <- go_co cxt kind_co
+           ; let tv' = setVarType tv $
+                       pFst (coercionKind kind_co')
+                 env' = extendVarEnv env tv tv'
+                 as'  = as `delVarSet` tv
+           ; body' <- go_co (as', env') body_co
+           ; return (ForAllCo tv' kind_co' body') }
+    go_co cxt (FunCo r co1 co2)         = do { co1' <- go_co cxt co1
+                                             ; co2' <- go_co cxt co2
+                                             ; return (mkFunCo r co1' co2') }
+    go_co cxt@(as,env) (CoVarCo c)
+      | c `elemVarSet` as               = Nothing
+      | Just c' <- lookupVarEnv env c   = return (mkCoVarCo c')
+      | otherwise                       = do { c' <- go_var cxt c
+                                             ; return (mkCoVarCo c') }
+    go_co cxt (HoleCo h)                = do { c' <- go_var cxt (ch_co_var h)
+                                             ; return (HoleCo (h { ch_co_var = c' })) }
+    go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args
+                                             ; return (mkAxiomInstCo ax ind args') }
+    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p
+                                             ; ty1' <- go cxt ty1
+                                             ; ty2' <- go cxt ty2
+                                             ; return (mkUnivCo p' r ty1' ty2') }
+    go_co cxt (SymCo co)                = do { co' <- go_co cxt co
+                                             ; return (mkSymCo co') }
+    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1
+                                             ; co2' <- go_co cxt co2
+                                             ; return (mkTransCo co1' co2') }
+    go_co cxt (NthCo r n co)            = do { co' <- go_co cxt co
+                                             ; return (mkNthCo r n co') }
+    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co
+                                             ; return (mkLRCo lr co') }
+    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co
+                                             ; arg' <- go_co cxt arg
+                                             ; return (mkInstCo co' arg') }
+    go_co cxt (KindCo co)               = do { co' <- go_co cxt co
+                                             ; return (mkKindCo co') }
+    go_co cxt (SubCo co)                = do { co' <- go_co cxt co
+                                             ; return (mkSubCo co') }
+    go_co cxt (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co cxt) cs
+                                             ; return (mkAxiomRuleCo ax cs') }
+
+    ------------------
+    go_prov _   UnsafeCoerceProv    = return UnsafeCoerceProv
+    go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co
+    go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co
+    go_prov _   p@(PluginProv _)    = return p
+
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -2376,11 +2764,12 @@ tyConsOfType ty
      go (TyConApp tc tys)           = go_tc tc `unionUniqSets` go_s tys
      go (AppTy a b)                 = go a `unionUniqSets` go b
      go (FunTy a b)                 = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon
-     go (ForAllTy (TvBndr tv _) ty) = go ty `unionUniqSets` go (tyVarKind tv)
+     go (ForAllTy (Bndr tv _) ty)   = go ty `unionUniqSets` go (varType tv)
      go (CastTy ty co)              = go ty `unionUniqSets` go_co co
      go (CoercionTy co)             = go_co co
 
-     go_co (Refl _ ty)             = go ty
+     go_co (Refl ty)               = go ty
+     go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco
      go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args
      go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg
      go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co
@@ -2388,21 +2777,23 @@ tyConsOfType ty
      go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args
      go_co (UnivCo p _ t1 t2)      = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2
      go_co (CoVarCo {})            = emptyUniqSet
+     go_co (HoleCo {})             = emptyUniqSet
      go_co (SymCo co)              = go_co co
      go_co (TransCo co1 co2)       = go_co co1 `unionUniqSets` go_co co2
-     go_co (NthCo _ co)            = go_co co
+     go_co (NthCo _ _ co)          = go_co co
      go_co (LRCo _ co)             = go_co co
      go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg
-     go_co (CoherenceCo co1 co2)   = go_co co1 `unionUniqSets` go_co co2
      go_co (KindCo co)             = go_co co
      go_co (SubCo co)              = go_co co
      go_co (AxiomRuleCo _ cs)      = go_cos cs
 
+     go_mco MRefl    = emptyUniqSet
+     go_mco (MCo co) = go_co co
+
      go_prov UnsafeCoerceProv    = emptyUniqSet
      go_prov (PhantomProv co)    = go_co co
      go_prov (ProofIrrelProv co) = go_co co
      go_prov (PluginProv _)      = emptyUniqSet
-     go_prov (HoleProv _)        = emptyUniqSet
         -- this last case can happen from the tyConsOfType used from
         -- checkTauTvUpdate
 
@@ -2432,9 +2823,9 @@ splitVisVarsOfType orig_ty = Pair invis_vars vis_vars
     go (AppTy t1 t2)     = go t1 `mappend` go t2
     go (TyConApp tc tys) = go_tc tc tys
     go (FunTy t1 t2)     = go t1 `mappend` go t2
-    go (ForAllTy (TvBndr tv _) ty)
+    go (ForAllTy (Bndr tv _) ty)
       = ((`delVarSet` tv) <$> go ty) `mappend`
-        (invisible (tyCoVarsOfType $ tyVarKind tv))
+        (invisible (tyCoVarsOfType $ varType tv))
     go (LitTy {}) = mempty
     go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)
     go (CoercionTy co) = invisible $ tyCoVarsOfCo co
@@ -2458,7 +2849,7 @@ modifyJoinResTy orig_ar f orig_ty
   where
     go 0 ty = f ty
     go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
-            = mkPiTy arg_bndr (go (n-1) res_ty)
+            = mkTyCoPiTy arg_bndr (go (n-1) res_ty)
             | otherwise
             = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty)
 
@@ -2469,3 +2860,20 @@ setJoinResTy :: Int  -- Number of binders to skip
 -- INVARIANT: Same as for modifyJoinResTy
 setJoinResTy ar new_res_ty ty
   = modifyJoinResTy ar (const new_res_ty) ty
+
+{-
+%************************************************************************
+%*                                                                      *
+         Pretty-printing
+%*                                                                      *
+%************************************************************************
+
+Most pretty-printing is either in TyCoRep or IfaceType.
+
+-}
+
+-- | This variant preserves any use of TYPE in a type, effectively
+-- locally setting -fprint-explicit-runtime-reps.
+pprWithTYPE :: Type -> SDoc
+pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $
+                 ppr ty
diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot
index 2fc251acb7..e5db1064d4 100644
--- a/compiler/types/Type.hs-boot
+++ b/compiler/types/Type.hs-boot
@@ -1,9 +1,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module Type where
+
+import GhcPrelude
 import TyCon
-import Var ( TyVar )
-import {-# SOURCE #-} TyCoRep( Type, Coercion, Kind )
+import Var ( TyCoVar )
+import {-# SOURCE #-} TyCoRep( Type, Coercion )
 import Util
 
 isPredTy     :: Type -> Bool
@@ -11,16 +13,14 @@ isCoercionTy :: Type -> Bool
 
 mkAppTy :: Type -> Type -> Type
 mkCastTy :: Type -> Coercion -> Type
-piResultTy :: Type -> Type -> Type
+piResultTy :: HasDebugCallStack => Type -> Type -> Type
 
-typeKind :: Type -> Kind
 eqType :: Type -> Type -> Bool
 
-partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a])
-
 coreView :: Type -> Maybe Type
 tcView :: Type -> Maybe Type
 
-tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
-tyCoVarsOfTypeWellScoped :: Type -> [TyVar]
+tyCoVarsOfTypesWellScoped :: [Type] -> [TyCoVar]
+tyCoVarsOfTypeWellScoped :: Type -> [TyCoVar]
+toposortTyVars :: [TyCoVar] -> [TyCoVar]
 splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 79d0897a14..cfa10e4196 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -26,15 +26,17 @@ module Unify (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Var
 import VarEnv
 import VarSet
-import Kind
 import Name( Name )
 import Type hiding ( getTvSubstEnv )
 import Coercion hiding ( getCvSubstEnv )
 import TyCon
 import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv )
+import FV( FV, fvVarSet, fvVarList )
 import Util
 import Pair
 import Outputable
@@ -42,9 +44,7 @@ import UniqFM
 import UniqSet
 
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import Control.Applicative hiding ( empty )
 import qualified Control.Applicative
 
@@ -70,6 +70,34 @@ Unification is much tricker than you might think.
    where x is the template type variable.  Then we do not want to
    bind x to a/b!  This is a kind of occurs check.
    The necessary locals accumulate in the RnEnv2.
+
+Note [tcMatchTy vs tcMatchTyKi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This module offers two variants of matching: with kinds and without.
+The TyKi variant takes two types, of potentially different kinds,
+and matches them. Along the way, it necessarily also matches their
+kinds. The Ty variant instead assumes that the kinds are already
+eqType and so skips matching up the kinds.
+
+How do you choose between them?
+
+1. If you know that the kinds of the two types are eqType, use
+   the Ty variant. It is more efficient, as it does less work.
+
+2. If the kinds of variables in the template type might mention type families,
+   use the Ty variant (and do other work to make sure the kinds
+   work out). These pure unification functions do a straightforward
+   syntactic unification and do no complex reasoning about type
+   families. Note that the types of the variables in instances can indeed
+   mention type families, so instance lookup must use the Ty variant.
+
+   (Nothing goes terribly wrong -- no panics -- if there might be type
+   families in kinds in the TyKi variant. You just might get match
+   failure even though a reducing a type family would lead to success.)
+
+3. Otherwise, if you're sure that the variable kinds do not mention
+   type families and you're not already sure that the kind of the template
+   equals the kind of the target, then use the TyKi version.
 -}
 
 -- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))
@@ -83,15 +111,18 @@ Unification is much tricker than you might think.
 -- by the match, because tcMatchTy (and similar functions) are
 -- always used on top-level types, so we can bind any of the
 -- free variables of the LHS.
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTy :: Type -> Type -> Maybe TCvSubst
 tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]
 
 -- | Like 'tcMatchTy', but allows the kinds of the types to differ,
 -- and thus matches them as well.
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTyKi :: Type -> Type -> Maybe TCvSubst
 tcMatchTyKi ty1 ty2 = tcMatchTyKis [ty1] [ty2]
 
 -- | This is similar to 'tcMatchTy', but extends a substitution
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTyX :: TCvSubst            -- ^ Substitution to extend
            -> Type                -- ^ Template
            -> Type                -- ^ Target
@@ -99,6 +130,7 @@ tcMatchTyX :: TCvSubst            -- ^ Substitution to extend
 tcMatchTyX subst ty1 ty2 = tcMatchTysX subst [ty1] [ty2]
 
 -- | Like 'tcMatchTy' but over a list of types.
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTys :: [Type]         -- ^ Template
            -> [Type]         -- ^ Target
            -> Maybe TCvSubst -- ^ One-shot; in principle the template
@@ -109,6 +141,7 @@ tcMatchTys tys1 tys2
     in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)
 
 -- | Like 'tcMatchTyKi' but over a list of types.
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTyKis :: [Type]         -- ^ Template
              -> [Type]         -- ^ Target
              -> Maybe TCvSubst -- ^ One-shot substitution
@@ -118,6 +151,7 @@ tcMatchTyKis tys1 tys2
     in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)
 
 -- | Like 'tcMatchTys', but extending a substitution
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTysX :: TCvSubst       -- ^ Substitution to extend
             -> [Type]         -- ^ Template
             -> [Type]         -- ^ Target
@@ -126,6 +160,7 @@ tcMatchTysX subst tys1 tys2
   = tc_match_tys_x False subst tys1 tys2
 
 -- | Like 'tcMatchTyKis', but extending a substitution
+-- See also Note [tcMatchTy vs tcMatchTyKi]
 tcMatchTyKisX :: TCvSubst        -- ^ Substitution to extend
               -> [Type]          -- ^ Template
               -> [Type]          -- ^ Target
@@ -394,7 +429,7 @@ tcUnifyTyKis bind_fn tys1 tys2
 type UnifyResult = UnifyResultM TCvSubst
 data UnifyResultM a = Unifiable a        -- the subst that unifies the types
                     | MaybeApart a       -- the subst has as much as we know
-                                         -- it must be part of an most general unifier
+                                         -- it must be part of a most general unifier
                                          -- See Note [The substitution in MaybeApart]
                     | SurelyApart
                     deriving Functor
@@ -463,6 +498,17 @@ tc_unify_tys :: (TyVar -> BindFlag)
              -> CvSubstEnv
              -> [Type] -> [Type]
              -> UnifyResultM (TvSubstEnv, CvSubstEnv)
+-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then
+-- the kinds of the types should be the same. However, this doesn't work,
+-- as the types may be a dependent telescope, where later types have kinds
+-- that mention variables occurring earlier in the list of types. Here's an
+-- example (from typecheck/should_fail/T12709):
+--   template: [rep :: RuntimeRep,       a :: TYPE rep]
+--   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]
+-- We can see that matching the first pair will make the kinds of the second
+-- pair equal. Yet, we still don't need a separate pass to unify the kinds
+-- of these types, so it's appropriate to use the Ty variant of unification.
+-- See also Note [tcMatchTy vs tcMatchTyKi].
 tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2
   = initUM tv_env cv_env $
     do { when match_kis $
@@ -471,6 +517,7 @@ tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2
        ; (,) <$> getTvSubstEnv <*> getCvSubstEnv }
   where
     env = UMEnv { um_bind_fun = bind_fn
+                , um_skols    = emptyVarSet
                 , um_unif     = unif
                 , um_inj_tf   = inj_check
                 , um_rn_env   = rn_env }
@@ -499,7 +546,7 @@ During unification we use a TvSubstEnv/CvSubstEnv pair that is
 Note [Finding the substitution fixpoint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Finding the fixpoint of a non-idempotent substitution arising from a
-unification is harder than it looks, because of kinds.  Consider
+unification is much trickier than it looks, because of kinds.  Consider
    T k (H k (f:k)) ~ T * (g:*)
 If we unify, we get the substitution
    [ k -> *
@@ -514,41 +561,96 @@ If we don't do this, we may apply the substitution to something,
 and get an ill-formed type, i.e. one where typeKind will fail.
 This happened, for example, in Trac #9106.
 
-This is the reason for extending env with [f:k -> f:*], in the
-definition of env' in niFixTvSubst
+It gets worse.  In Trac #14164 we wanted to take the fixpoint of
+this substitution
+   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)
+                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))
+   , a_aY6  :-> a_aXQ ]
+
+We have to apply the substitution for a_aY6 two levels deep inside
+the invocation of F!  We don't have a function that recursively
+applies substitutions inside the kinds of variable occurrences (and
+probably rightly so).
+
+So, we work as follows:
+
+ 1. Start with the current substitution (which we are
+    trying to fixpoint
+       [ xs :-> F a (z :: a) (rest :: G a (z :: a))
+       , a  :-> b ]
+
+ 2. Take all the free vars of the range of the substitution:
+       {a, z, rest, b}
+    NB: the free variable finder closes over
+    the kinds of variable occurrences
+
+ 3. If none are in the domain of the substitution, stop.
+    We have found a fixpoint.
+
+ 4. Remove the variables that are bound by the substitution, leaving
+       {z, rest, b}
+
+ 5. Do a topo-sort to put them in dependency order:
+       [ b :: *, z :: a, rest :: G a z ]
+
+ 6. Apply the substitution left-to-right to the kinds of these
+    tyvars, extending it each time with a new binding, so we
+    finish up with
+       [ xs   :-> ..as before..
+       , a    :-> b
+       , b    :-> b    :: *
+       , z    :-> z    :: b
+       , rest :-> rest :: G b (z :: b) ]
+    Note that rest now has the right kind
+
+ 7. Apply this extended substitution (once) to the range of
+    the /original/ substitution.  (Note that we do the
+    extended substitution would go on forever if you tried
+    to find its fixpoint, because it maps z to z.)
+
+ 8. And go back to step 1
+
+In Step 6 we use the free vars from Step 2 as the initial
+in-scope set, because all of those variables appear in the
+range of the substitution, so they must all be in the in-scope
+set.  But NB that the type substitution engine does not look up
+variables in the in-scope set; it is used only to ensure no
+shadowing.
 -}
 
 niFixTCvSubst :: TvSubstEnv -> TCvSubst
 -- Find the idempotent fixed point of the non-idempotent substitution
--- See Note [Finding the substitution fixpoint]
+-- This is surprisingly tricky:
+--   see Note [Finding the substitution fixpoint]
 -- ToDo: use laziness instead of iteration?
-niFixTCvSubst tenv = f tenv
+niFixTCvSubst tenv
+  | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv)
+  | otherwise    = subst
   where
-    f tenv
-        | not_fixpoint = f (mapVarEnv (substTy subst') tenv)
-        | otherwise    = subst
-        where
-          not_fixpoint  = anyVarSet in_domain range_tvs
-          in_domain tv  = tv `elemVarEnv` tenv
-
-          range_tvs     = nonDetFoldUFM (unionVarSet . tyCoVarsOfType) emptyVarSet tenv
-                          -- It's OK to use nonDetFoldUFM here because we
-                          -- forget the order immediately by creating a set
-          subst         = mkTvSubst (mkInScopeSet range_tvs) tenv
-
-             -- env' extends env by replacing any free type with
-             -- that same tyvar with a substituted kind
-             -- See note [Finding the substitution fixpoint]
-          tenv'  = extendVarEnvList tenv [ (rtv, mkTyVarTy $
-                                                 setTyVarKind rtv $
-                                                 substTy subst $
-                                                 tyVarKind rtv)
-                                         | rtv <- nonDetEltsUniqSet range_tvs
-                                         -- It's OK to use nonDetEltsUniqSet here
-                                         -- because we forget the order
-                                         -- immediatedly by putting it in VarEnv
-                                         , not (in_domain rtv) ]
-          subst' = mkTvSubst (mkInScopeSet range_tvs) tenv'
+    range_fvs :: FV
+    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)
+          -- It's OK to use nonDetEltsUFM here because the
+          -- order of range_fvs, range_tvs is immaterial
+
+    range_tvs :: [TyVar]
+    range_tvs = fvVarList range_fvs
+
+    not_fixpoint  = any in_domain range_tvs
+    in_domain tv  = tv `elemVarEnv` tenv
+
+    free_tvs = toposortTyVars (filterOut in_domain range_tvs)
+
+    -- See Note [Finding the substitution fixpoint], Step 6
+    init_in_scope = mkInScopeSet (fvVarSet range_fvs)
+    subst = foldl' add_free_tv
+                  (mkTvSubst init_in_scope tenv)
+                  free_tvs
+
+    add_free_tv :: TCvSubst -> TyVar -> TCvSubst
+    add_free_tv subst tv
+      = extendTvSubst subst tv (mkTyVarTy tv')
+     where
+        tv' = updateTyVarKind (substTy subst) tv
 
 niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet
 -- Apply the non-idempotent substitution to a set of type variables,
@@ -711,7 +813,7 @@ Consider this:
    type instance Foo MkG = False
 
 We would like that to be accepted. For that to work, we need to introduce
-a coercion variable on the left an then use it on the right. Accordingly,
+a coercion variable on the left and then use it on the right. Accordingly,
 at use sites of Foo, we need to be able to use matching to figure out the
 value for the coercion. (See the desugared version:
 
@@ -771,6 +873,41 @@ dependent/should_compile/KindEqualities2, we see, for example the
 constraint Num (Int |> (blah ; sym blah)).  We naturally want to find
 a dictionary for that constraint, which requires dealing with
 coercions in this manner.
+
+Note [Matching in the presence of casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When matching, it is crucial that no variables from the template
+end up in the range of the matching substitution (obviously!).
+When unifying, that's not a constraint; instead we take the fixpoint
+of the substitution at the end.
+
+So what should we do with this, when matching?
+   unify_ty (tmpl |> co) tgt kco
+
+Previously, wrongly, we pushed 'co' in the (horrid) accumulating
+'kco' argument like this:
+   unify_ty (tmpl |> co) tgt kco
+     = unify_ty tmpl tgt (kco ; co)
+
+But that is obviously wrong because 'co' (from the template) ends
+up in 'kco', which in turn ends up in the range of the substitution.
+
+This all came up in Trac #13910.  Because we match tycon arguments
+left-to-right, the ambient substitution will already have a matching
+substitution for any kinds; so there is an easy fix: just apply
+the substitution-so-far to the coercion from the LHS.
+
+Note that
+
+* When matching, the first arg of unify_ty is always the template;
+  we never swap round.
+
+* The above argument is distressingly indirect. We seek a
+  better way.
+
+* One better way is to ensure that type patterns (the template
+  in the matching process) have no casts.  See Trac #14119.
+
 -}
 
 -------------- unify_ty: the main workhorse -----------
@@ -780,7 +917,7 @@ type AmIUnifying = Bool   -- True  <=> Unifying
 
 unify_ty :: UMEnv
          -> Type -> Type  -- Types to be unified and a co
-         -> Coercion      -- A coercion between their kinds
+         -> CoercionN     -- A coercion between their kinds
                           -- See Note [Kind coercions in Unify]
          -> UM ()
 -- See Note [Specification of unification]
@@ -790,7 +927,12 @@ unify_ty env ty1 ty2 kco
     -- TODO: More commentary needed here
   | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco
   | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco
-  | CastTy ty1' co <- ty1     = unify_ty env ty1' ty2 (co `mkTransCo` kco)
+  | CastTy ty1' co <- ty1     = if um_unif env
+                                then unify_ty env ty1' ty2 (co `mkTransCo` kco)
+                                else -- See Note [Matching in the presence of casts]
+                                     do { subst <- getSubst env
+                                        ; let co' = substCo subst co
+                                        ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) }
   | CastTy ty2' co <- ty2     = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co)
 
 unify_ty env (TyVarTy tv1) ty2 kco
@@ -802,11 +944,11 @@ unify_ty env ty1 (TyVarTy tv2) kco
 unify_ty env ty1 ty2 _kco
   | Just (tc1, tys1) <- mb_tc_app1
   , Just (tc2, tys2) <- mb_tc_app2
-  , tc1 == tc2 || (tcIsStarKind ty1 && tcIsStarKind ty2)
+  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)
   = if isInjectiveTyCon tc1 Nominal
     then unify_tys env tys1 tys2
     else do { let inj | isTypeFamilyTyCon tc1
-                      = case familyTyConInjectivityInfo tc1 of
+                      = case tyConInjectivityInfo tc1 of
                                NotInjective -> repeat False
                                Injective bs -> bs
                       | otherwise
@@ -853,8 +995,8 @@ unify_ty env ty1 (AppTy ty2a ty2b) _kco
 
 unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()
 
-unify_ty env (ForAllTy (TvBndr tv1 _) ty1) (ForAllTy (TvBndr tv2 _) ty2) kco
-  = do { unify_ty env (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind)
+unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco
+  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)
        ; let env' = umRnBndr2 env tv1 tv2
        ; unify_ty env' ty1 ty2 kco }
 
@@ -865,9 +1007,9 @@ unify_ty env (CoercionTy co1) (CoercionTy co2) kco
            CoVarCo cv
              | not (um_unif env)
              , not (cv `elemVarEnv` c_subst)
-             , BindMe <- tvBindFlagL env cv
-             -> do { checkRnEnvRCo env co2
-                   ; let (co_l, co_r) = decomposeFunCo kco
+             , BindMe <- tvBindFlag env cv
+             -> do { checkRnEnv env (tyCoVarsOfCo co2)
+                   ; let (co_l, co_r) = decomposeFunCo Nominal kco
                       -- cv :: t1 ~ t2
                       -- co2 :: s1 ~ s2
                       -- co_l :: t1 ~ s1
@@ -906,27 +1048,30 @@ unify_tys env orig_xs orig_ys
 
 ---------------------------------
 uVar :: UMEnv
-     -> TyVar           -- Variable to be unified
+     -> InTyVar         -- Variable to be unified
      -> Type            -- with this Type
      -> Coercion        -- :: kind tv ~N kind ty
      -> UM ()
 
 uVar env tv1 ty kco
- = do { -- Check to see whether tv1 is refined by the substitution
-        subst <- getTvSubstEnv
-      ; case (lookupVarEnv subst tv1) of
-          Just ty' | um_unif env                 -- Unifying, so
-                   -> unify_ty env ty' ty kco   -- call back into unify
+ = do { -- Apply the ambient renaming
+        let tv1' = umRnOccL env tv1
+
+        -- Check to see whether tv1 is refined by the substitution
+      ; subst <- getTvSubstEnv
+      ; case (lookupVarEnv subst tv1') of
+          Just ty' | um_unif env                -- Unifying, so call
+                   -> unify_ty env ty' ty kco   -- back into unify
                    | otherwise
                    -> -- Matching, we don't want to just recur here.
                       -- this is because the range of the subst is the target
                       -- type, not the template type. So, just check for
                       -- normal type equality.
                       guard ((ty' `mkCastTy` kco) `eqType` ty)
-          Nothing  -> uUnrefined env tv1 ty ty kco } -- No, continue
+          Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue
 
 uUnrefined :: UMEnv
-           -> TyVar             -- variable to be unified
+           -> OutTyVar          -- variable to be unified
            -> Type              -- with this Type
            -> Type              -- (version w/ expanded synonyms)
            -> Coercion          -- :: kind tv ~N kind ty
@@ -934,36 +1079,35 @@ uUnrefined :: UMEnv
 
 -- We know that tv1 isn't refined
 
-uUnrefined env tv1 ty2 ty2' kco
+uUnrefined env tv1' ty2 ty2' kco
   | Just ty2'' <- coreView ty2'
-  = uUnrefined env tv1 ty2 ty2'' kco    -- Unwrap synonyms
+  = uUnrefined env tv1' ty2 ty2'' kco    -- Unwrap synonyms
                 -- This is essential, in case we have
                 --      type Foo a = a
                 -- and then unify a ~ Foo a
 
   | TyVarTy tv2 <- ty2'
-  = do { let tv1' = umRnOccL env tv1
-             tv2' = umRnOccR env tv2
+  = do { let tv2' = umRnOccR env tv2
+       ; unless (tv1' == tv2' && um_unif env) $ do
+           -- If we are unifying a ~ a, just return immediately
+           -- Do not extend the substitution
            -- See Note [Self-substitution when matching]
-       ; when (tv1' /= tv2' || not (um_unif env)) $ do
-       { subst <- getTvSubstEnv
+
           -- Check to see whether tv2 is refined
+       { subst <- getTvSubstEnv
        ; case lookupVarEnv subst tv2 of
-         {  Just ty' | um_unif env -> uUnrefined env tv1 ty' ty' kco
-         ;  _                      -> do
-       {   -- So both are unrefined
-
-           -- And then bind one or the other,
-           -- depending on which is bindable
-       ; let b1  = tvBindFlagL env tv1
-             b2  = tvBindFlagR env tv2
-             ty1 = mkTyVarTy tv1
+         {  Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco
+         ;  _ ->
+
+    do {   -- So both are unrefined
+           -- Bind one or the other, depending on which is bindable
+       ; let b1  = tvBindFlag env tv1'
+             b2  = tvBindFlag env tv2'
+             ty1 = mkTyVarTy tv1'
        ; case (b1, b2) of
-           (BindMe, _) -> do { checkRnEnvR env ty2 -- make sure ty2 is not a local
-                             ; extendTvEnv tv1 (ty2 `mkCastTy` mkSymCo kco) }
+           (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)
            (_, BindMe) | um_unif env
-                       -> do { checkRnEnvL env ty1 -- ditto for ty1
-                             ; extendTvEnv tv2 (ty1 `mkCastTy` kco) }
+                       -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco)
 
            _ | tv1' == tv2' -> return ()
              -- How could this happen? If we're only matching and if
@@ -972,25 +1116,37 @@ uUnrefined env tv1 ty2 ty2' kco
            _ -> maybeApart -- See Note [Unification with skolems]
   }}}}
 
-uUnrefined env tv1 ty2 ty2' kco -- ty2 is not a type variable
-  = do { occurs <- elemNiSubstSet tv1 (tyCoVarsOfType ty2')
-       ; if um_unif env && occurs  -- See Note [Self-substitution when matching]
-         then maybeApart       -- Occurs check, see Note [Fine-grained unification]
-         else do bindTv env tv1 (ty2 `mkCastTy` mkSymCo kco) }
-            -- Bind tyvar to the synonym if poss
+uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable
+  = case tvBindFlag env tv1' of
+      Skolem -> maybeApart  -- See Note [Unification with skolems]
+      BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)
+
+bindTv :: UMEnv -> OutTyVar -> Type -> UM ()
+-- OK, so we want to extend the substitution with tv := ty
+-- But first, we must do a couple of checks
+bindTv env tv1 ty2
+  = do  { let free_tvs2 = tyCoVarsOfType ty2
+
+        -- Make sure tys mentions no local variables
+        -- E.g.  (forall a. b) ~ (forall a. [a])
+        -- We should not unify b := [a]!
+        ; checkRnEnv env free_tvs2
 
-elemNiSubstSet :: TyVar -> TyCoVarSet -> UM Bool
-elemNiSubstSet v set
+        -- Occurs check, see Note [Fine-grained unification]
+        -- Make sure you include 'kco' (which ty2 does) Trac #14846
+        ; occurs <- occursCheck env tv1 free_tvs2
+
+        ; if occurs then maybeApart
+                    else extendTvEnv tv1 ty2 }
+
+occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool
+occursCheck env tv free_tvs
+  | um_unif env
   = do { tsubst <- getTvSubstEnv
-       ; return $ v `elemVarSet` niSubstTvSet tsubst set }
+       ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) }
 
-bindTv :: UMEnv -> TyVar -> Type -> UM ()
-bindTv env tv ty    -- ty is not a variable
-  = do  { checkRnEnvR env ty -- make sure ty mentions no local variables
-        ; case tvBindFlagL env tv of
-            Skolem -> maybeApart  -- See Note [Unification with skolems]
-            BindMe -> extendTvEnv tv ty
-        }
+  | otherwise      -- Matching; no occurs check
+  = return False   -- See Note [Self-substitution when matching]
 
 {-
 %************************************************************************
@@ -1015,12 +1171,27 @@ data BindFlag
 ************************************************************************
 -}
 
-data UMEnv = UMEnv { um_bind_fun :: TyVar -> BindFlag
-                                       -- User-supplied BindFlag function
-                   , um_unif     :: AmIUnifying
-                   , um_inj_tf   :: Bool         -- Checking for injectivity?
-                          -- See (end of) Note [Specification of unification]
-                   , um_rn_env   :: RnEnv2 }
+data UMEnv
+  = UMEnv { um_unif :: AmIUnifying
+
+          , um_inj_tf :: Bool
+            -- Checking for injectivity?
+            -- See (end of) Note [Specification of unification]
+
+          , um_rn_env :: RnEnv2
+            -- Renaming InTyVars to OutTyVars; this eliminates
+            -- shadowing, and lines up matching foralls on the left
+            -- and right
+
+          , um_skols :: TyVarSet
+            -- OutTyVars bound by a forall in this unification;
+            -- Do not bind these in the substitution!
+            -- See the function tvBindFlag
+
+          , um_bind_fun :: TyVar -> BindFlag
+            -- User-supplied BindFlag function,
+            -- for variables not in um_skols
+          }
 
 data UMState = UMState
                    { um_tv_env   :: TvSubstEnv
@@ -1036,7 +1207,7 @@ instance Applicative UM where
       (<*>)  = ap
 
 instance Monad UM where
-  fail _   = UM (\_ -> SurelyApart) -- failed pattern match
+  fail     = MonadFail.fail
   m >>= k  = UM (\state ->
                   do { (state', v) <- unUM m state
                      ; unUM (k v) state' })
@@ -1050,10 +1221,8 @@ instance Alternative UM where
 
 instance MonadPlus UM
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail UM where
     fail _   = UM (\_ -> SurelyApart) -- failed pattern match
-#endif
 
 initUM :: TvSubstEnv  -- subst to extend
        -> CvSubstEnv
@@ -1067,15 +1236,10 @@ initUM subst_env cv_subst_env um
     state = UMState { um_tv_env = subst_env
                     , um_cv_env = cv_subst_env }
 
-tvBindFlagL :: UMEnv -> TyVar -> BindFlag
-tvBindFlagL env tv
-  | inRnEnvL (um_rn_env env) tv = Skolem
-  | otherwise                   = um_bind_fun env tv
-
-tvBindFlagR :: UMEnv -> TyVar -> BindFlag
-tvBindFlagR env tv
-  | inRnEnvR (um_rn_env env) tv = Skolem
-  | otherwise                   = um_bind_fun env tv
+tvBindFlag :: UMEnv -> OutTyVar -> BindFlag
+tvBindFlag env tv
+  | tv `elemVarSet` um_skols env = Skolem
+  | otherwise                    = um_bind_fun env tv
 
 getTvSubstEnv :: UM TvSubstEnv
 getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)
@@ -1083,6 +1247,12 @@ getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)
 getCvSubstEnv :: UM CvSubstEnv
 getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)
 
+getSubst :: UMEnv -> UM TCvSubst
+getSubst env = do { tv_env <- getTvSubstEnv
+                  ; cv_env <- getCvSubstEnv
+                  ; let in_scope = rnInScopeSet (um_rn_env env)
+                  ; return (mkTCvSubst in_scope (tv_env, cv_env)) }
+
 extendTvEnv :: TyVar -> Type -> UM ()
 extendTvEnv tv ty = UM $ \state ->
   Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())
@@ -1093,17 +1263,22 @@ extendCvEnv cv co = UM $ \state ->
 
 umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv
 umRnBndr2 env v1 v2
-  = env { um_rn_env = rnBndr2 (um_rn_env env) v1 v2 }
-
-checkRnEnv :: (RnEnv2 -> VarEnv Var) -> UMEnv -> VarSet -> UM ()
-checkRnEnv get_set env varset = UM $ \ state ->
-  let env_vars = get_set (um_rn_env env) in
-  if isEmptyVarEnv env_vars || (getUniqSet varset `disjointVarEnv` env_vars)
-     -- NB: That isEmptyVarSet is a critical optimization; it
-     -- means we don't have to calculate the free vars of
-     -- the type, often saving quite a bit of allocation.
-  then Unifiable  (state, ())
-  else MaybeApart (state, ())
+  = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' }
+  where
+    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2
+
+checkRnEnv :: UMEnv -> VarSet -> UM ()
+checkRnEnv env varset
+  | isEmptyVarSet skol_vars           = return ()
+  | varset `disjointVarSet` skol_vars = return ()
+  | otherwise                         = maybeApart
+               -- ToDo: why MaybeApart?
+               -- I think SurelyApart would be right
+  where
+    skol_vars = um_skols env
+    -- NB: That isEmptyVarSet guard is a critical optimization;
+    -- it means we don't have to calculate the free vars of
+    -- the type, often saving quite a bit of allocation.
 
 -- | Converts any SurelyApart to a MaybeApart
 don'tBeSoSure :: UM () -> UM ()
@@ -1112,15 +1287,6 @@ don'tBeSoSure um = UM $ \ state ->
     SurelyApart -> MaybeApart (state, ())
     other       -> other
 
-checkRnEnvR :: UMEnv -> Type -> UM ()
-checkRnEnvR env ty = checkRnEnv rnEnvR env (tyCoVarsOfType ty)
-
-checkRnEnvL :: UMEnv -> Type -> UM ()
-checkRnEnvL env ty = checkRnEnv rnEnvL env (tyCoVarsOfType ty)
-
-checkRnEnvRCo :: UMEnv -> Coercion -> UM ()
-checkRnEnvRCo env co = checkRnEnv rnEnvR env (tyCoVarsOfCo co)
-
 umRnOccL :: UMEnv -> TyVar -> TyVar
 umRnOccL env v = rnOccL (um_rn_env env) v
 
@@ -1152,7 +1318,7 @@ data MatchEnv = ME { me_tmpls :: TyVarSet
                    , me_env   :: RnEnv2 }
 
 -- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if
---   @liftCoMatch vars ty co == Just s@, then @listCoSubst s ty == co@,
+--   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,
 --   where @==@ there means that the result of 'liftCoSubst' has the same
 --   type as the original co; but may be different under the hood.
 --   That is, it matches a type against a coercion of the same
@@ -1217,10 +1383,13 @@ ty_co_match menv subst ty co lkco rkco
 
 ty_co_match menv subst ty co lkco rkco
   | CastTy ty' co' <- ty
-  = ty_co_match menv subst ty' co (co' `mkTransCo` lkco) (co' `mkTransCo` rkco)
-
-  | CoherenceCo co1 co2 <- co
-  = ty_co_match menv subst ty co1 (lkco `mkTransCo` mkSymCo co2) rkco
+     -- See Note [Matching in the presence of casts]
+  = let empty_subst  = mkEmptyTCvSubst (rnInScopeSet (me_env menv))
+        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'
+        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'
+    in
+    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)
+                                  (substed_co_r `mkTransCo` rkco)
 
   | SymCo co' <- co
   = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco
@@ -1236,7 +1405,7 @@ ty_co_match menv subst (TyVarTy tv1) co lkco rkco
   = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)
     then Nothing      -- occurs check failed
     else Just $ extendVarEnv subst tv1' $
-                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)
+                castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco)
 
   | otherwise
   = Nothing
@@ -1269,9 +1438,10 @@ ty_co_match menv subst (FunTy ty1 ty2) co _lkco _rkco
   = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2]
     in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos
 
-ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1)
+ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)
                        (ForAllCo tv2 kind_co2 co2)
                        lkco rkco
+  | isTyVar tv1 && isTyVar tv2
   = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2
                                ki_ki_co ki_ki_co
        ; let rn_env0 = me_env menv
@@ -1281,9 +1451,47 @@ ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1)
   where
     ki_ki_co = mkNomReflCo liftedTypeKind
 
+-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)
+--                        (ForAllCo cv2 kind_co2 co2)
+--                        lkco rkco
+--   | isCoVar cv1 && isCoVar cv2
+--   We seems not to have enough information for this case
+--   1. Given:
+--        cv1      :: (s1 :: k1) ~r (s2 :: k2)
+--        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)
+--        eta1      = mkNthCo role 2 (downgradeRole r Nominal kind_co2)
+--                 :: s1' ~ t1
+--        eta2      = mkNthCo role 3 (downgradeRole r Nominal kind_co2)
+--                 :: s2' ~ t2
+--      Wanted:
+--        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2
+--        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4
+--      Question: How do we get kcoi?
+--   2. Given:
+--        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in Type
+--        rkco :: <*>
+--      Wanted:
+--        ty_co_match menv' subst2 ty1 co2 lkco' rkco'
+--      Question: How do we get lkco' and rkco'?
+
 ty_co_match _ subst (CoercionTy {}) _ _ _
   = Just subst -- don't inspect coercions
 
+ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco
+  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)
+
+ty_co_match menv subst ty co1 lkco rkco
+  | Just (CastTy t co, r) <- isReflCo_maybe co1
+  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us
+  -- t |> co ~ t ; <t> ; t ~ t |> co
+  -- But transitive coercions are not helpful. Therefore we deal
+  -- with it here: we do recursion on the smaller reflexive coercion,
+  -- while propagating the correct kind coercions.
+  = let kco' = mkSymCo co
+    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')
+                                                (rkco `mkTransCo` kco')
+
+
 ty_co_match menv subst ty co lkco rkco
   | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco
   | otherwise               = Nothing
@@ -1328,17 +1536,18 @@ ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos)
 ty_co_match_args _    _     _        _          _ _ = Nothing
 
 pushRefl :: Coercion -> Maybe Coercion
-pushRefl (Refl Nominal (AppTy ty1 ty2))
-  = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2))
-pushRefl (Refl r (FunTy ty1 ty2))
-  | Just rep1 <- getRuntimeRep_maybe ty1
-  , Just rep2 <- getRuntimeRep_maybe ty2
-  = Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2
-                                , mkReflCo r ty1,  mkReflCo r ty2 ])
-pushRefl (Refl r (TyConApp tc tys))
-  = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
-pushRefl (Refl r (ForAllTy (TvBndr tv _) ty))
-  = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty))
+pushRefl co =
+  case (isReflCo_maybe co) of
+    Just (AppTy ty1 ty2, Nominal)
+      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))
+    Just (FunTy ty1 ty2, r)
+      | Just rep1 <- getRuntimeRep_maybe ty1
+      , Just rep2 <- getRuntimeRep_maybe ty2
+      ->  Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2
+                                       , mkReflCo r ty1,  mkReflCo r ty2 ])
+    Just (TyConApp tc tys, r)
+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))
+    Just (ForAllTy (Bndr tv _) ty, r)
+      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))
     -- NB: NoRefl variant. Otherwise, we get a loop!
-pushRefl (Refl r (CastTy ty co))  = Just (castCoercionKind (Refl r ty) co co)
-pushRefl _                        = Nothing
+    _ -> Nothing
diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs
index 55f9d6d551..36fb7ef6cb 100644
--- a/compiler/utils/AsmUtils.hs
+++ b/compiler/utils/AsmUtils.hs
@@ -6,6 +6,8 @@ module AsmUtils
     ( sectionType
     ) where
 
+import GhcPrelude
+
 import Platform
 import Outputable
 
diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs
index fffbb6eb12..41c80390cc 100644
--- a/compiler/utils/Bag.hs
+++ b/compiler/utils/Bag.hs
@@ -18,13 +18,15 @@ module Bag (
         concatBag, catBagMaybes, foldBag, foldrBag, foldlBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,
         listToBag, bagToList, mapAccumBagL,
-        concatMapBag, mapMaybeBag,
+        concatMapBag, concatMapBagPair, mapMaybeBag,
         foldrBagM, foldlBagM, mapBagM, mapBagM_,
         flatMapBagM, flatMapBagPairM,
         mapAndUnzipBagM, mapAccumBagLM,
         anyBagM, filterBagM
     ) where
 
+import GhcPrelude
+
 import Outputable
 import Util
 
@@ -230,6 +232,19 @@ concatMapBag f (UnitBag x)     = f x
 concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2)
 concatMapBag f (ListBag xs)    = foldr (unionBags . f) emptyBag xs
 
+concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c)
+concatMapBagPair _ EmptyBag        = (EmptyBag, EmptyBag)
+concatMapBagPair f (UnitBag x)     = f x
+concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2)
+  where
+    (r1, s1) = concatMapBagPair f b1
+    (r2, s2) = concatMapBagPair f b2
+concatMapBagPair f (ListBag xs)    = foldr go (emptyBag, emptyBag) xs
+  where
+    go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2)
+      where
+        (r1, r2) = f a
+
 mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b
 mapMaybeBag _ EmptyBag        = EmptyBag
 mapMaybeBag f (UnitBag x)     = case f x of
@@ -313,6 +328,7 @@ mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM f s xs
 
 listToBag :: [a] -> Bag a
 listToBag [] = EmptyBag
+listToBag [x] = UnitBag x
 listToBag vs = ListBag vs
 
 bagToList :: Bag a -> [a]
@@ -328,5 +344,8 @@ instance Data a => Data (Bag a) where
   dataTypeOf _ = mkNoRepType "Bag"
   dataCast1 x  = gcast1 x
 
+instance Functor Bag where
+    fmap = mapBag
+
 instance Foldable.Foldable Bag where
     foldr = foldrBag
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 99ab07ec33..447317ca47 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -3,8 +3,9 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
 
-{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -59,6 +60,8 @@ module Binary
 -- The *host* architecture version:
 #include "../includes/MachDeps.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} Name (Name)
 import FastString
 import Panic
@@ -76,14 +79,10 @@ import qualified Data.ByteString.Unsafe   as BS
 import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Time
-#if MIN_VERSION_base(4,10,0)
 import Type.Reflection
 import Type.Reflection.Unsafe
 import Data.Kind (Type)
-import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
-#else
-import Data.Typeable
-#endif
+import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))
 import Control.Monad            ( when )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
@@ -498,7 +497,7 @@ instance Binary DiffTime where
 --
 -- TODO  This instance is not architecture portable.  GMP stores numbers as
 -- arrays of machine sized words, so the byte format is not portable across
--- architectures with different endianess and word size.
+-- architectures with different endianness and word size.
 --
 -- This makes it hard (impossible) to make an equivalent instance
 -- with code that is compilable with non-GHC.  Do we need any instance
@@ -607,7 +606,6 @@ instance Binary (Bin a) where
 -- -----------------------------------------------------------------------------
 -- Instances for Data.Typeable stuff
 
-#if MIN_VERSION_base(4,10,0)
 instance Binary TyCon where
     put_ bh tc = do
         put_ bh (tyConPackage tc)
@@ -617,17 +615,7 @@ instance Binary TyCon where
         put_ bh (tyConKindRep tc)
     get bh =
         mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-#else
-instance Binary TyCon where
-    put_ bh tc = do
-        put_ bh (tyConPackage tc)
-        put_ bh (tyConModule tc)
-        put_ bh (tyConName tc)
-    get bh =
-        mkTyCon3 <$> get bh <*> get bh <*> get bh
-#endif
 
-#if MIN_VERSION_base(4,10,0)
 instance Binary VecCount where
     put_ bh = putByte bh . fromIntegral . fromEnum
     get bh = toEnum . fromIntegral <$> getByte bh
@@ -746,14 +734,18 @@ getSomeTypeRep bh = do
                        ]
         3 -> do SomeTypeRep arg <- getSomeTypeRep bh
                 SomeTypeRep res <- getSomeTypeRep bh
-                case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
-                  Just HRefl ->
-                      case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
-                        Just HRefl -> return $ SomeTypeRep $ Fun arg res
-                        Nothing -> failure "Kind mismatch" []
-                  _ -> failure "Kind mismatch" []
+                if
+                  | App argkcon _ <- typeRepKind arg
+                  , App reskcon _ <- typeRepKind res
+                  , Just HRefl <- argkcon `eqTypeRep` tYPErep
+                  , Just HRefl <- reskcon `eqTypeRep` tYPErep
+                  -> return $ SomeTypeRep $ Fun arg res
+                  | otherwise -> failure "Kind mismatch" []
         _ -> failure "Invalid SomeTypeRep" []
   where
+    tYPErep :: TypeRep TYPE
+    tYPErep = typeRep
+
     failure description info =
         fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]
                       ++ map ("    "++) info
@@ -774,17 +766,6 @@ instance Typeable a => Binary (TypeRep (a :: k)) where
 instance Binary SomeTypeRep where
     put_ bh (SomeTypeRep rep) = putTypeRep bh rep
     get = getSomeTypeRep
-#else
-instance Binary TypeRep where
-    put_ bh type_rep = do
-        let (ty_con, child_type_reps) = splitTyConApp type_rep
-        put_ bh ty_con
-        put_ bh child_type_reps
-    get bh = do
-        ty_con <- get bh
-        child_type_reps <- get bh
-        return (mkTyConApp ty_con child_type_reps)
-#endif
 
 -- -----------------------------------------------------------------------------
 -- Lazy reading/writing
@@ -1031,14 +1012,14 @@ instance Binary RuleMatchInfo where
                       else return FunLike
 
 instance Binary InlineSpec where
-    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh NoUserInline    = putByte bh 0
     put_ bh Inline          = putByte bh 1
     put_ bh Inlinable       = putByte bh 2
     put_ bh NoInline        = putByte bh 3
 
     get bh = do h <- getByte bh
                 case h of
-                  0 -> return EmptyInlineSpec
+                  0 -> return NoUserInline
                   1 -> return Inline
                   2 -> return Inlinable
                   _ -> return NoInline
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs
index 43a71f0080..a42bb90a1c 100644
--- a/compiler/utils/BooleanFormula.hs
+++ b/compiler/utils/BooleanFormula.hs
@@ -16,6 +16,8 @@ module BooleanFormula (
         pprBooleanFormula, pprBooleanFormulaNice
   ) where
 
+import GhcPrelude
+
 import Data.List ( nub, intersperse )
 import Data.Data
 
diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs
index eff57059de..99c043ce41 100644
--- a/compiler/utils/BufWrite.hs
+++ b/compiler/utils/BufWrite.hs
@@ -20,9 +20,12 @@ module BufWrite (
         bPutFS,
         bPutFZS,
         bPutLitString,
+        bPutReplicate,
         bFlush,
   ) where
 
+import GhcPrelude
+
 import FastString
 import FastMutInt
 
@@ -95,19 +98,45 @@ bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do
                 copyBytes (buf `plusPtr` i) ptr len
                 writeFastMutInt r (i + len)
 
-bPutLitString :: BufHandle -> LitString -> Int -> IO ()
-bPutLitString b@(BufHandle buf r hdl) a len = a `seq` do
+bPutLitString :: BufHandle -> LitString -> IO ()
+bPutLitString b@(BufHandle buf r hdl) l@(LitString a len) = l `seq` do
   i <- readFastMutInt r
   if (i+len) >= buf_size
         then do hPutBuf hdl buf i
                 writeFastMutInt r 0
                 if (len >= buf_size)
                     then hPutBuf hdl a len
-                    else bPutLitString b a len
+                    else bPutLitString b l
         else do
                 copyBytes (buf `plusPtr` i) a len
                 writeFastMutInt r (i+len)
 
+-- | Replicate an 8-bit character
+bPutReplicate :: BufHandle -> Int -> Char -> IO ()
+bPutReplicate (BufHandle buf r hdl) len c = do
+  i <- readFastMutInt r
+  let oc = fromIntegral (ord c)
+  if (i+len) < buf_size
+    then do
+      fillBytes (buf `plusPtr` i) oc len
+      writeFastMutInt r (i+len)
+    else do
+      -- flush the current buffer
+      when (i /= 0) $ hPutBuf hdl buf i
+      if (len < buf_size)
+        then do
+          fillBytes buf oc len
+          writeFastMutInt r len
+        else do
+          -- fill a full buffer
+          fillBytes buf oc buf_size
+          -- flush it as many times as necessary
+          let go n | n >= buf_size = do
+                                       hPutBuf hdl buf buf_size
+                                       go (n-buf_size)
+                   | otherwise     = writeFastMutInt r n
+          go len
+
 bFlush :: BufHandle -> IO ()
 bFlush (BufHandle buf r hdl) = do
   i <- readFastMutInt r
diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs
index e3b5037bf3..c420486ed1 100644
--- a/compiler/utils/Digraph.hs
+++ b/compiler/utils/Digraph.hs
@@ -7,12 +7,10 @@ module Digraph(
 
         SCC(..), Node(..), flattenSCC, flattenSCCs,
         stronglyConnCompG,
-        topologicalSortG, dfsTopSortG,
+        topologicalSortG,
         verticesG, edgesG, hasVertexG,
         reachableG, reachablesG, transposeG,
-        outdegreeG, indegreeG,
-        vertexGroupsG, emptyG,
-        componentsG,
+        emptyG,
 
         findCycle,
 
@@ -40,20 +38,16 @@ module Digraph(
 ------------------------------------------------------------------------------
 
 
+import GhcPrelude
+
 import Util        ( minWith, count )
 import Outputable
 import Maybes      ( expectJust )
-import MonadUtils  ( allM )
-
--- Extensions
-import Control.Monad    ( filterM, liftM, liftM2 )
-import Control.Monad.ST
 
 -- std interfaces
 import Data.Maybe
 import Data.Array
 import Data.List hiding (transpose)
-import Data.Array.ST
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -314,7 +308,7 @@ stronglyConnCompFromEdgedVerticesUniq
   = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
 
 -- The "R" interface is used when you expect to apply SCC to
--- (some of) the result of SCC, so you dont want to lose the dependency info
+-- (some of) the result of SCC, so you don't want to lose the dependency info
 -- See Note [Deterministic SCC]
 -- See Note [reduceNodesIntoVertices implementations]
 stronglyConnCompFromEdgedVerticesOrdR
@@ -325,7 +319,7 @@ stronglyConnCompFromEdgedVerticesOrdR =
   stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
 
 -- The "R" interface is used when you expect to apply SCC to
--- (some of) the result of SCC, so you dont want to lose the dependency info
+-- (some of) the result of SCC, so you don't want to lose the dependency info
 -- See Note [Deterministic SCC]
 -- See Note [reduceNodesIntoVertices implementations]
 stronglyConnCompFromEdgedVerticesUniqR
@@ -347,12 +341,6 @@ topologicalSortG :: Graph node -> [node]
 topologicalSortG graph = map (gr_vertex_to_node graph) result
   where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
 
-dfsTopSortG :: Graph node -> [[node]]
-dfsTopSortG graph =
-  map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g)
-  where
-    g = gr_int_graph graph
-
 reachableG :: Graph node -> node -> [node]
 reachableG graph from = map (gr_vertex_to_node graph) result
   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
@@ -379,27 +367,9 @@ transposeG graph = Graph (G.transposeG (gr_int_graph graph))
                          (gr_vertex_to_node graph)
                          (gr_node_to_vertex graph)
 
-outdegreeG :: Graph node -> node -> Maybe Int
-outdegreeG = degreeG outdegree
-
-indegreeG :: Graph node -> node -> Maybe Int
-indegreeG = degreeG indegree
-
-degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int
-degreeG degree graph node = let table = degree (gr_int_graph graph)
-                            in fmap ((!) table) $ gr_node_to_vertex graph node
-
-vertexGroupsG :: Graph node -> [[node]]
-vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
-  where result = vertexGroups (gr_int_graph graph)
-
 emptyG :: Graph node -> Bool
 emptyG g = graphEmpty (gr_int_graph g)
 
-componentsG :: Graph node -> [[node]]
-componentsG graph = map (map (gr_vertex_to_node graph) . flatten)
-                  $ components (gr_int_graph graph)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -450,58 +420,3 @@ preorderF ts         = concat (map flatten ts)
 -- This generalizes reachable which was found in Data.Graph
 reachable    :: IntGraph -> [Vertex] -> [Vertex]
 reachable g vs = preorderF (dfs g vs)
-
-{-
-------------------------------------------------------------
--- Total ordering on groups of vertices
-------------------------------------------------------------
-
-The plan here is to extract a list of groups of elements of the graph
-such that each group has no dependence except on nodes in previous
-groups (i.e. in particular they may not depend on nodes in their own
-group) and is maximal such group.
-
-Clearly we cannot provide a solution for cyclic graphs.
-
-We proceed by iteratively removing elements with no outgoing edges
-and their associated edges from the graph.
-
-This probably isn't very efficient and certainly isn't very clever.
--}
-
-type Set s    = STArray s Vertex Bool
-
-mkEmpty      :: Bounds -> ST s (Set s)
-mkEmpty bnds  = newArray bnds False
-
-contains     :: Set s -> Vertex -> ST s Bool
-contains m v  = readArray m v
-
-include      :: Set s -> Vertex -> ST s ()
-include m v   = writeArray m v True
-
-vertexGroups :: IntGraph -> [[Vertex]]
-vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
-  where next_vertices = noOutEdges g
-
-noOutEdges :: IntGraph -> [Vertex]
-noOutEdges g = [ v | v <- vertices g, null (g!v)]
-
-vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
-vertexGroupsS provided g to_provide
-  = if null to_provide
-    then do {
-          all_provided <- allM (provided `contains`) (vertices g)
-        ; if all_provided
-          then return []
-          else error "vertexGroup: cyclic graph"
-        }
-    else do {
-          mapM_ (include provided) to_provide
-        ; to_provide' <- filterM (vertexReady provided g) (vertices g)
-        ; rest <- vertexGroupsS provided g to_provide'
-        ; return $ to_provide : rest
-        }
-
-vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
-vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))
diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs
index f2b0979995..b4af68621d 100644
--- a/compiler/utils/Encoding.hs
+++ b/compiler/utils/Encoding.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O2 #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -33,6 +33,8 @@ module Encoding (
         toBase62Padded
   ) where
 
+import GhcPrelude
+
 import Foreign
 import Foreign.ForeignPtr.Unsafe
 import Data.Char
diff --git a/compiler/utils/EnumSet.hs b/compiler/utils/EnumSet.hs
index aa36b788aa..670a5c64c8 100644
--- a/compiler/utils/EnumSet.hs
+++ b/compiler/utils/EnumSet.hs
@@ -1,4 +1,4 @@
--- | An tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum'
+-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum'
 -- things.
 module EnumSet
     ( EnumSet
@@ -10,6 +10,8 @@ module EnumSet
     , empty
     ) where
 
+import GhcPrelude
+
 import qualified Data.IntSet as IntSet
 
 newtype EnumSet a = EnumSet IntSet.IntSet
diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index 850393e359..9d9b3ae25c 100644
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -6,6 +6,8 @@ module Exception
     )
     where
 
+import GhcPrelude
+
 import Control.Exception
 import Control.Monad.IO.Class
 
diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs
index b5cf096aac..6d0dc2b2ab 100644
--- a/compiler/utils/FV.hs
+++ b/compiler/utils/FV.hs
@@ -26,6 +26,8 @@ module FV (
         mapUnionFV,
     ) where
 
+import GhcPrelude
+
 import Var
 import VarSet
 
diff --git a/compiler/utils/FastFunctions.hs b/compiler/utils/FastFunctions.hs
index c643e3c8fb..be3f3cbee4 100644
--- a/compiler/utils/FastFunctions.hs
+++ b/compiler/utils/FastFunctions.hs
@@ -10,6 +10,8 @@ module FastFunctions (
 
 #include "HsVersions.h"
 
+import GhcPrelude ()
+
 import GHC.Exts
 import GHC.IO   (IO(..))
 
diff --git a/compiler/utils/FastMutInt.hs b/compiler/utils/FastMutInt.hs
index 2a6e7b83aa..20206f8b1e 100644
--- a/compiler/utils/FastMutInt.hs
+++ b/compiler/utils/FastMutInt.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O2 #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 --
@@ -15,6 +15,8 @@ module FastMutInt(
         readFastMutPtr, writeFastMutPtr
   ) where
 
+import GhcPrelude
+
 import Data.Bits
 import GHC.Base
 import GHC.Ptr
diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index 8653485e0c..6ca3043668 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -2,7 +2,7 @@
 
 {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,
     GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -O -funbox-strict-fields #-}
+{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -18,7 +18,7 @@
 --
 -- ['LitString']
 --
---   * Just a wrapper for the @Addr#@ of a C string (@Ptr CChar@).
+--   * Pointer and size of a Latin-1 encoded string.
 --   * Practically no operations.
 --   * Outputing them is fast.
 --   * Generated by 'sLit'.
@@ -81,7 +81,7 @@ module FastString
         hasZEncoding,
 
         -- * LitStrings
-        LitString,
+        LitString (..),
 
         -- ** Construction
         sLit,
@@ -97,6 +97,8 @@ module FastString
 
 #include "HsVersions.h"
 
+import GhcPrelude as Prelude
+
 import Encoding
 import FastFunctions
 import Panic
@@ -118,6 +120,7 @@ import Data.IORef       ( IORef, newIORef, readIORef, atomicModifyIORef' )
 import Data.Maybe       ( isJust )
 import Data.Char
 import Data.List        ( elemIndex )
+import Data.Semigroup as Semi
 
 import GHC.IO           ( IO(..), unsafeDupablePerformIO )
 
@@ -127,7 +130,7 @@ import Foreign
 import GHC.Conc.Sync    (sharedCAF)
 #endif
 
-import GHC.Base         ( unpackCString# )
+import GHC.Base         ( unpackCString#, unpackNBytes# )
 
 #define hASH_TBL_SIZE          4091
 #define hASH_TBL_SIZE_UNBOXED  4091#
@@ -202,9 +205,12 @@ instance Ord FastString where
 instance IsString FastString where
     fromString = fsLit
 
+instance Semi.Semigroup FastString where
+    (<>) = appendFS
+
 instance Monoid FastString where
     mempty = nilFS
-    mappend = appendFS
+    mappend = (Semi.<>)
     mconcat = concatFS
 
 instance Show FastString where
@@ -221,7 +227,7 @@ cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) =
   if u1 == u2 then EQ else
   compare (fastStringToByteString f1) (fastStringToByteString f2)
 
-foreign import ccall unsafe "ghc_memcmp"
+foreign import ccall unsafe "memcmp"
   memcmp :: Ptr a -> Ptr b -> Int -> IO Int
 
 -- -----------------------------------------------------------------------------
@@ -562,15 +568,12 @@ hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs
 -- -----------------------------------------------------------------------------
 -- LitStrings, here for convenience only.
 
--- | A 'LitString' is a pointer to some null-terminated array of bytes.
-type LitString = Ptr Word8
---Why do we recalculate length every time it's requested?
---If it's commonly needed, we should perhaps have
---data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int#
+-- | A 'LitString' is a pointer to some array of Latin-1 encoded chars.
+data LitString = LitString !(Ptr Word8) !Int
 
 -- | Wrap an unboxed address into a 'LitString'.
 mkLitString# :: Addr# -> LitString
-mkLitString# a# = Ptr a#
+mkLitString# a# = LitString (Ptr a#) (ptrStrLength (Ptr a#))
 
 -- | Encode a 'String' into a newly allocated 'LitString' using Latin-1
 -- encoding.  The original string must not contain non-Latin-1 characters
@@ -578,32 +581,34 @@ mkLitString# a# = Ptr a#
 {-# INLINE mkLitString #-}
 mkLitString :: String -> LitString
 mkLitString s =
+ -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks
+ -- and because someone might be using `eqAddr#` to check for string equality.
  unsafePerformIO (do
-   p <- mallocBytes (length s + 1)
+   let len = length s
+   p <- mallocBytes len
    let
      loop :: Int -> String -> IO ()
-     loop !n [] = pokeByteOff p n (0 :: Word8)
+     loop !_ []    = return ()
      loop n (c:cs) = do
         pokeByteOff p n (fromIntegral (ord c) :: Word8)
         loop (1+n) cs
    loop 0 s
-   return p
+   return (LitString p len)
  )
 
 -- | Decode a 'LitString' back into a 'String' using Latin-1 encoding.
 -- This does not free the memory associated with 'LitString'.
 unpackLitString :: LitString -> String
-unpackLitString (Ptr p) = unpackCString# p
+unpackLitString (LitString (Ptr p#) (I# n#)) = unpackNBytes# p# n#
 
--- | Compute the length of a 'LitString', which must necessarily be
--- null-terminated.
+-- | Return the length of a 'LitString'
 lengthLS :: LitString -> Int
-lengthLS = ptrStrLength
+lengthLS (LitString _ n) = n
 
 -- -----------------------------------------------------------------------------
 -- under the carpet
 
-foreign import ccall unsafe "ghc_strlen"
+foreign import ccall unsafe "strlen"
   ptrStrLength :: Ptr Word8 -> Int
 
 {-# NOINLINE sLit #-}
diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs
index 14b0859211..1b4af6cee7 100644
--- a/compiler/utils/FastStringEnv.hs
+++ b/compiler/utils/FastStringEnv.hs
@@ -27,6 +27,8 @@ module FastStringEnv (
         mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv
     ) where
 
+import GhcPrelude
+
 import UniqFM
 import UniqDFM
 import Maybes
diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc
index d4cee0e10b..01de554869 100644
--- a/compiler/utils/Fingerprint.hsc
+++ b/compiler/utils/Fingerprint.hsc
@@ -24,6 +24,8 @@ module Fingerprint (
 #include "md5.h"
 ##include "HsVersions.h"
 
+import GhcPrelude
+
 import Foreign
 import GHC.IO
 import Numeric          ( readHex )
@@ -40,7 +42,6 @@ readHexFingerprint s = Fingerprint w1 w2
        [(w1,"")] = readHex s1
        [(w2,"")] = readHex (take 16 s2)
 
--- this can move to GHC.Fingerprint in GHC 8.6
 fingerprintByteString :: BS.ByteString -> Fingerprint
 fingerprintByteString bs = unsafeDupablePerformIO $
   BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len
diff --git a/compiler/utils/FiniteMap.hs b/compiler/utils/FiniteMap.hs
index cb6e5573e8..0692830932 100644
--- a/compiler/utils/FiniteMap.hs
+++ b/compiler/utils/FiniteMap.hs
@@ -7,21 +7,23 @@ module FiniteMap (
         foldRight, foldRightWithKey
     ) where
 
+import GhcPrelude
+
 import Data.Map (Map)
 import qualified Data.Map as Map
 
 insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt
-insertList xs m = foldl (\m (k, v) -> Map.insert k v m) m xs
+insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs
 
 insertListWith :: Ord key
                => (elt -> elt -> elt)
                -> [(key,elt)]
                -> Map key elt
                -> Map key elt
-insertListWith f xs m0 = foldl (\m (k, v) -> Map.insertWith f k v m) m0 xs
+insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs
 
 deleteList :: Ord key => [key] -> Map key elt -> Map key elt
-deleteList ks m = foldl (flip Map.delete) m ks
+deleteList ks m = foldl' (flip Map.delete) m ks
 
 foldRight        :: (elt -> a -> a) -> a -> Map key elt -> a
 foldRight        = Map.foldr
diff --git a/compiler/utils/GhcPrelude.hs b/compiler/utils/GhcPrelude.hs
new file mode 100644
index 0000000000..66d01be5f8
--- /dev/null
+++ b/compiler/utils/GhcPrelude.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+
+-- | Custom GHC "Prelude"
+--
+-- This module serves as a replacement for the "Prelude" module
+-- and abstracts over differences between the bootstrapping
+-- GHC version, and may also provide a common default vocabulary.
+--
+module GhcPrelude (module X) where
+
+-- We export the 'Semigroup' class but w/o the (<>) operator to avoid
+-- clashing with the (Outputable.<>) operator which is heavily used
+-- through GHC's code-base.
+
+#if MIN_VERSION_base(4,11,0)
+import Prelude as X hiding ((<>))
+#else
+import Prelude as X
+import Data.Semigroup as X (Semigroup)
+#endif
+
+import Data.Foldable as X (foldl')
+
+{-
+Note [Why do we import Prelude here?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and
+ghc-heap.cabal contain the directive default-extensions:
+NoImplicitPrelude. There are two motivations for this:
+  - Consistency with the compiler directory, which enables
+    NoImplicitPrelude;
+  - Allows loading the above dependent packages with ghc-in-ghci,
+    giving a smoother development experience when adding new
+    extensions.
+-}
diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs
index c3850dfdd6..b66599356e 100644
--- a/compiler/utils/GraphBase.hs
+++ b/compiler/utils/GraphBase.hs
@@ -12,6 +12,8 @@ module GraphBase (
 
 where
 
+import GhcPrelude
+
 import UniqSet
 import UniqFM
 
diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs
index be7975b306..4c1388e91d 100644
--- a/compiler/utils/GraphColor.hs
+++ b/compiler/utils/GraphColor.hs
@@ -12,6 +12,8 @@ module GraphColor (
 
 where
 
+import GhcPrelude
+
 import GraphBase
 import GraphOps
 import GraphPpr
@@ -114,7 +116,7 @@ colorGraph iterative spinCount colors triv spill graph0
 -- | Scan through the conflict graph separating out trivially colorable and
 --      potentially uncolorable (problem) nodes.
 --
---      Checking whether a node is trivially colorable or not is a resonably expensive operation,
+--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
 --      so after a triv node is found and removed from the graph it's no good to return to the 'start'
 --      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
 --
@@ -191,7 +193,7 @@ colorScan_spin iterative triv spill graph
 
                 -- we were able to coalesce something
                 --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
-                (graph2, kksCoalesceFound @(_:_))
+                (graph2, kksCoalesceFound@(_:_))
                  -> colorScan_spin iterative triv spill graph2
                         ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
 
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 565134be92..bb4504ff1f 100644
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -18,6 +18,8 @@ module GraphOps (
 )
 where
 
+import GhcPrelude
+
 import GraphBase
 
 import Outputable
diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
index a40e1058d0..c39395eda8 100644
--- a/compiler/utils/GraphPpr.hs
+++ b/compiler/utils/GraphPpr.hs
@@ -7,6 +7,8 @@ module GraphPpr (
 )
 where
 
+import GhcPrelude
+
 import GraphBase
 
 import Outputable
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 29854c51fe..4640b2b7c2 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 --
 -- (c) The University of Glasgow 2002-2006
 --
@@ -31,6 +29,8 @@ module IOEnv (
         atomicUpdMutVar, atomicUpdMutVar'
   ) where
 
+import GhcPrelude
+
 import DynFlags
 import Exception
 import Module
@@ -41,9 +41,7 @@ import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import Control.Monad
-#if __GLASGOW_HASKELL__ > 710
 import qualified Control.Monad.Fail as MonadFail
-#endif
 import MonadUtils
 import Control.Applicative (Alternative(..))
 
@@ -60,13 +58,10 @@ unIOEnv (IOEnv m) = m
 instance Monad (IOEnv m) where
     (>>=)  = thenM
     (>>)   = (*>)
-    fail _ = failM -- Ignore the string
+    fail   = MonadFail.fail
 
-#if __GLASGOW_HASKELL__ > 710
 instance MonadFail.MonadFail (IOEnv m) where
     fail _ = failM -- Ignore the string
-#endif
-
 
 instance Applicative (IOEnv m) where
     pure = returnM
@@ -111,7 +106,7 @@ instance ExceptionMonad (IOEnv a) where
 
 instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
     getDynFlags = do env <- getEnv
-                     return $ extractDynFlags env
+                     return $! extractDynFlags env
 
 instance ContainsModule env => HasModule (IOEnv env) where
     getModule = do env <- getEnv
diff --git a/compiler/utils/Json.hs b/compiler/utils/Json.hs
index 1318ce2611..2bf00d3851 100644
--- a/compiler/utils/Json.hs
+++ b/compiler/utils/Json.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE GADTs #-}
 module Json where
 
+import GhcPrelude
+
 import Outputable
 import Data.Char
 import Numeric
@@ -39,7 +41,7 @@ escapeJsonString = concatMap escapeChar
     escapeChar '\n' = "\\n"
     escapeChar '\r' = "\\r"
     escapeChar '\t' = "\\t"
-    escapeChar '"'  = "\""
+    escapeChar '"'  = "\\\""
     escapeChar '\\'  = "\\\\"
     escapeChar c | isControl c || fromEnum c >= 0x7f  = uni_esc c
     escapeChar c = [c]
diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs
index f1aa2c3755..1a134d5dc8 100644
--- a/compiler/utils/ListSetOps.hs
+++ b/compiler/utils/ListSetOps.hs
@@ -8,7 +8,7 @@
 {-# LANGUAGE CPP #-}
 
 module ListSetOps (
-        unionLists, minusList,
+        unionLists, minusList, deleteBys,
 
         -- Association lists
         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -23,16 +23,25 @@ module ListSetOps (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Outputable
 import Util
 
 import Data.List
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Set as S
 
 getNth :: Outputable a => [a] -> Int -> a
 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
              xs !! n
 
+deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+-- (deleteBys eq xs ys) returns xs-ys, using the given equality function
+-- Just like 'Data.List.delete' but with an equality function
+deleteBys eq xs ys = foldl' (flip (deleteBy eq)) xs ys
+
 {-
 ************************************************************************
 *                                                                      *
@@ -131,19 +140,19 @@ hasNoDups xs = f [] xs
 
 equivClasses :: (a -> a -> Ordering) -- Comparison
              -> [a]
-             -> [[a]]
+             -> [NonEmpty a]
 
-equivClasses _         []  = []
-equivClasses _   stuff@[_] = [stuff]
-equivClasses cmp items     = groupBy eq (sortBy cmp items)
+equivClasses _   []      = []
+equivClasses _   [stuff] = [stuff :| []]
+equivClasses cmp items   = NE.groupBy eq (sortBy cmp items)
   where
     eq a b = case cmp a b of { EQ -> True; _ -> False }
 
 removeDups :: (a -> a -> Ordering) -- Comparison function
            -> [a]
-           -> ([a],     -- List with no duplicates
-               [[a]])   -- List of duplicate groups.  One representative from
-                        -- each group appears in the first result
+           -> ([a],          -- List with no duplicates
+               [NonEmpty a]) -- List of duplicate groups.  One representative
+                             -- from each group appears in the first result
 
 removeDups _   []  = ([], [])
 removeDups _   [x] = ([x],[])
@@ -151,12 +160,12 @@ removeDups cmp xs
   = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
     (xs', dups) }
   where
-    collect_dups _           []         = panic "ListSetOps: removeDups"
-    collect_dups dups_so_far [x]        = (dups_so_far,      x)
-    collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
+    collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
+    collect_dups dups_so_far (x :| [])     = (dups_so_far,      x)
+    collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
 
-findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
+findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
 findDupsEq _  [] = []
 findDupsEq eq (x:xs) | null eq_xs  = findDupsEq eq xs
-                     | otherwise   = (x:eq_xs) : findDupsEq eq neq_xs
+                     | otherwise   = (x :| eq_xs) : findDupsEq eq neq_xs
     where (eq_xs, neq_xs) = partition (eq x) xs
diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs
index 2b81db1ed4..c16701419d 100644
--- a/compiler/utils/ListT.hs
+++ b/compiler/utils/ListT.hs
@@ -29,9 +29,12 @@ module ListT (
     fold
   ) where
 
+import GhcPrelude
+
 import Control.Applicative
 
 import Control.Monad
+import Control.Monad.Fail as MonadFail
 
 -------------------------------------------------------------------------
 -- | A monad transformer for performing backtracking computations
@@ -64,6 +67,9 @@ instance Alternative (ListT f) where
 
 instance Monad (ListT m) where
     m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk
+    fail = MonadFail.fail
+
+instance MonadFail (ListT m) where
     fail _ = ListT $ \_ fk -> fk
 
 instance MonadPlus (ListT m) where
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 89dd5b4fae..3a139a5b36 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -23,6 +23,8 @@ module Maybes (
         MaybeT(..), liftMaybeT, tryMaybeT
     ) where
 
+import GhcPrelude
+
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Exception (catch, SomeException(..))
diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs
index 93a835e04e..39a76e1cf2 100644
--- a/compiler/utils/MonadUtils.hs
+++ b/compiler/utils/MonadUtils.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 -- | Utilities related to Monad and Applicative classes
 --   Mostly for backwards compatibility.
 
@@ -29,14 +27,13 @@ module MonadUtils
 -- Imports
 -------------------------------------------------------------------------------
 
+import GhcPrelude
+
 import Maybes
 
 import Control.Monad
 import Control.Monad.Fix
 import Control.Monad.IO.Class
-#if __GLASGOW_HASKELL__ < 800
-import Control.Monad.Trans.Error () -- for orphan `instance MonadPlus IO`
-#endif
 
 -------------------------------------------------------------------------------
 -- Lift combinators
diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs
index 3c5b9d7380..a5739764d4 100644
--- a/compiler/utils/OrdList.hs
+++ b/compiler/utils/OrdList.hs
@@ -9,19 +9,18 @@ Provide trees (of instructions), so that lists of instructions
 can be appended in linear time.
 -}
 
-{-# LANGUAGE CPP #-}
 module OrdList (
         OrdList,
         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
         mapOL, fromOL, toOL, foldrOL, foldlOL
 ) where
 
+import GhcPrelude
+
 import Outputable
 
-#if __GLASGOW_HASKELL__ > 710
 import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
-#endif
 
 infixl 5  `appOL`
 infixl 5  `snocOL`
@@ -39,14 +38,12 @@ data OrdList a
 instance Outputable a => Outputable (OrdList a) where
   ppr ol = ppr (fromOL ol)  -- Convert to list and print that
 
-#if __GLASGOW_HASKELL__ > 710
 instance Semigroup (OrdList a) where
   (<>) = appOL
-#endif
 
 instance Monoid (OrdList a) where
   mempty = nilOL
-  mappend = appOL
+  mappend = (Semigroup.<>)
   mconcat = concatOL
 
 instance Functor OrdList where
@@ -125,4 +122,5 @@ foldlOL k z (Many xs)   = foldl k z xs
 
 toOL :: [a] -> OrdList a
 toOL [] = None
+toOL [x] = One x
 toOL xs = Many xs
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 4107e5beef..929c7f3d58 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP, ImplicitParams #-}
 {-
 (c) The University of Glasgow 2006-2012
 (c) The GRASP Project, Glasgow University, 1992-1998
@@ -16,20 +15,20 @@ module Outputable (
 
         -- * Pretty printing combinators
         SDoc, runSDoc, initSDocContext,
-        docToSDoc, sdocWithPprDebug,
+        docToSDoc,
         interppSP, interpp'SP,
         pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
         pprWithBars,
         empty, isEmpty, nest,
         char,
         text, ftext, ptext, ztext,
-        int, intWithCommas, integer, float, double, rational, doublePrec,
+        int, intWithCommas, integer, word, float, double, rational, doublePrec,
         parens, cparen, brackets, braces, quotes, quote,
-        doubleQuotes, angleBrackets, paBrackets,
+        doubleQuotes, angleBrackets,
         semi, comma, colon, dcolon, space, equals, dot, vbar,
         arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
-        blankLine, forAllLit, kindStar, bullet,
+        blankLine, forAllLit, kindType, bullet,
         (<>), (<+>), hcat, hsep,
         ($$), ($+$), vcat,
         sep, cat,
@@ -70,24 +69,31 @@ module Outputable (
         alwaysQualifyPackages, neverQualifyPackages,
         QualifyName(..), queryQual,
         sdocWithDynFlags, sdocWithPlatform,
+        updSDocDynFlags,
         getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured,
         pprDeeper, pprDeeperList, pprSetDepth,
         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
-        ifPprDebug, qualName, qualModule, qualPackage,
+        qualName, qualModule, qualPackage,
         mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
         mkUserStyle, cmdlineParserStyle, Depth(..),
 
+        ifPprDebug, whenPprDebug, getPprDebug,
+
         -- * Error handling and debugging utilities
         pprPanic, pprSorry, assertPprPanic, pprPgmError,
         pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace,
+        pprTraceException, pprTraceM,
         trace, pgmError, panic, sorry, assertPanic,
-        pprDebugAndThen, callStackDoc
+        pprDebugAndThen, callStackDoc,
     ) where
 
+import GhcPrelude
+
 import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
                                   targetPlatform, pprUserLength, pprCols,
-                                  useUnicode, useUnicodeSyntax,
-                                  shouldUseColor, unsafeGlobalDynFlags )
+                                  useUnicode, useUnicodeSyntax, useStarIsType,
+                                  shouldUseColor, unsafeGlobalDynFlags,
+                                  shouldUseHexWordLiterals )
 import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
 import {-# SOURCE #-}   OccName( OccName )
 
@@ -122,6 +128,9 @@ import Data.List (intersperse)
 
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
+import GHC.Stack        ( callStack, prettyCallStack )
+import Control.Monad.IO.Class
+import Exception
 
 {-
 ************************************************************************
@@ -172,12 +181,8 @@ data PrintUnqualified = QueryQualify {
     queryQualifyPackage :: QueryQualifyPackage
 }
 
--- | given an /original/ name, this function tells you which module
--- name it should be qualified with when printing for the user, if
--- any.  For example, given @Control.Exception.catch@, which is in scope
--- as @Exception.catch@, this function will return @Just "Exception"@.
--- Note that the return value is a ModuleName, not a Module, because
--- in source code, names are qualified by ModuleNames.
+-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify
+-- it.
 type QueryQualifyName = Module -> OccName -> QualifyName
 
 -- | For a given module, we need to know whether to print it with
@@ -247,8 +252,8 @@ defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay
 defaultDumpStyle :: DynFlags -> PprStyle
  -- Print without qualifiers to reduce verbosity, unless -dppr-debug
 defaultDumpStyle dflags
-   |  hasPprDebug dflags = PprDebug
-   |  otherwise          = PprDump neverQualify
+   | hasPprDebug dflags = PprDebug
+   | otherwise          = PprDump neverQualify
 
 mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle
 mkDumpStyle dflags print_unqual
@@ -339,9 +344,6 @@ withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
 withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
 withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
 
-sdocWithPprDebug :: (Bool -> SDoc) -> SDoc
-sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags)
-
 pprDeeper :: SDoc -> SDoc
 pprDeeper d = SDoc $ \ctx -> case ctx of
   SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
@@ -382,6 +384,10 @@ sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
 sdocWithPlatform :: (Platform -> SDoc) -> SDoc
 sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
 
+updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc
+updSDocDynFlags upd doc
+  = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) })
+
 qualName :: PprStyle -> QueryQualifyName
 qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
 qualName (PprDump q)     mod occ = queryQualifyName q mod occ
@@ -422,11 +428,16 @@ userStyle ::  PprStyle -> Bool
 userStyle (PprUser {}) = True
 userStyle _other       = False
 
-ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
-ifPprDebug d = SDoc $ \ctx ->
-    case ctx of
-        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
-        _                       -> Pretty.empty
+getPprDebug :: (Bool -> SDoc) -> SDoc
+getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty)
+
+ifPprDebug :: SDoc -> SDoc -> SDoc
+-- ^ Says what to do with and without -dppr-debug
+ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no
+
+whenPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
+-- ^ Says what to do with -dppr-debug; without, return empty
+whenPprDebug d = ifPprDebug d empty
 
 -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
 --   terminal doesn't get screwed up by the ANSI color codes if an exception
@@ -546,6 +557,7 @@ ptext    :: LitString  -> SDoc
 ztext    :: FastZString -> SDoc
 int      :: Int        -> SDoc
 integer  :: Integer    -> SDoc
+word     :: Integer    -> SDoc
 float    :: Float      -> SDoc
 double   :: Double     -> SDoc
 rational :: Rational   -> SDoc
@@ -564,6 +576,11 @@ integer n   = docToSDoc $ Pretty.integer n
 float n     = docToSDoc $ Pretty.float n
 double n    = docToSDoc $ Pretty.double n
 rational n  = docToSDoc $ Pretty.rational n
+word n      = sdocWithDynFlags $ \dflags ->
+    -- See Note [Print Hexadecimal Literals] in Pretty.hs
+    if shouldUseHexWordLiterals dflags
+        then docToSDoc $ Pretty.hex n
+        else docToSDoc $ Pretty.integer n
 
 -- | @doublePrec p n@ shows a floating point number @n@ with @p@
 -- digits of precision after the decimal point.
@@ -571,7 +588,7 @@ doublePrec :: Int -> Double -> SDoc
 doublePrec p n = text (showFFloat (Just p) n "")
 
 parens, braces, brackets, quotes, quote,
-        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
+        doubleQuotes, angleBrackets :: SDoc -> SDoc
 
 parens d        = SDoc $ Pretty.parens . runSDoc d
 braces d        = SDoc $ Pretty.braces . runSDoc d
@@ -579,7 +596,6 @@ brackets d      = SDoc $ Pretty.brackets . runSDoc d
 quote d         = SDoc $ Pretty.quote . runSDoc d
 doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d
 angleBrackets d = char '<' <> d <> char '>'
-paBrackets d    = text "[:" <> d <> text ":]"
 
 cparen :: Bool -> SDoc -> SDoc
 cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
@@ -630,8 +646,11 @@ rbrace     = docToSDoc $ Pretty.rbrace
 forAllLit :: SDoc
 forAllLit = unicodeSyntax (char '∀') (text "forall")
 
-kindStar :: SDoc
-kindStar = unicodeSyntax (char '★') (char '*')
+kindType :: SDoc
+kindType = sdocWithDynFlags $ \dflags ->
+    if useStarIsType dflags
+    then unicodeSyntax (char '★') (char '*')
+    else text "Type"
 
 bullet :: SDoc
 bullet = unicode (char '•') (char '*')
@@ -779,6 +798,9 @@ instance Outputable Int64 where
 instance Outputable Int where
     ppr n = int n
 
+instance Outputable Integer where
+    ppr n = integer n
+
 instance Outputable Word16 where
     ppr n = integer $ fromIntegral n
 
@@ -957,9 +979,9 @@ pprPrimChar :: Char -> SDoc
 pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
 pprPrimChar c   = pprHsChar c <> primCharSuffix
 pprPrimInt i    = integer i   <> primIntSuffix
-pprPrimWord w   = integer w   <> primWordSuffix
+pprPrimWord w   = word    w   <> primWordSuffix
 pprPrimInt64 i  = integer i   <> primInt64Suffix
-pprPrimWord64 w = integer w   <> primWord64Suffix
+pprPrimWord64 w = word    w   <> primWord64Suffix
 
 ---------------------
 -- Put a name in parens if it's an operator
@@ -1013,7 +1035,7 @@ pprQuotedList :: Outputable a => [a] -> SDoc
 pprQuotedList = quotedList . map ppr
 
 quotedList :: [SDoc] -> SDoc
-quotedList xs = hsep (punctuate comma (map quotes xs))
+quotedList xs = fsep (punctuate comma (map quotes xs))
 
 quotedListWithOr :: [SDoc] -> SDoc
 -- [x,y,z]  ==>  `x', `y' or `z'
@@ -1130,7 +1152,8 @@ doOrDoes _   = text "do"
 
 callStackDoc :: HasCallStack => SDoc
 callStackDoc =
-    hang (text "Call stack:") 4 (vcat $ map text $ lines prettyCurrentCallStack)
+    hang (text "Call stack:")
+       4 (vcat $ map text $ lines (prettyCallStack callStack))
 
 pprPanic :: HasCallStack => String -> SDoc -> a
 -- ^ Throw an exception saying "bug in GHC"
@@ -1157,10 +1180,20 @@ pprTrace str doc x
    | otherwise                             =
       pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
 
+pprTraceM :: Applicative f => String -> SDoc -> f ()
+pprTraceM str doc = pprTrace str doc (pure ())
+
 -- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
 pprTraceIt :: Outputable a => String -> a -> a
 pprTraceIt desc x = pprTrace desc (ppr x) x
 
+-- | @pprTraceException desc x action@ runs action, printing a message
+-- if it throws an exception.
+pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
+pprTraceException heading doc =
+    handleGhcException $ \exc -> liftIO $ do
+        putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc])
+        throwGhcExceptionIO exc
 
 -- | If debug output is on, show some 'SDoc' on the screen along
 -- with a call stack when available.
@@ -1183,9 +1216,7 @@ warnPprTrace True   file  line  msg x
 -- line number. Should typically be accessed with the ASSERT family of macros
 assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a
 assertPprPanic _file _line msg
-  = pprPanic "ASSERT failed!" doc
-  where
-    doc = sep [ msg, callStackDoc ]
+  = pprPanic "ASSERT failed!" msg
 
 pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
 pprDebugAndThen dflags cont heading pretty_msg
diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot
index 980c186889..ad7d091833 100644
--- a/compiler/utils/Outputable.hs-boot
+++ b/compiler/utils/Outputable.hs-boot
@@ -1,5 +1,7 @@
 module Outputable where
 
+import GhcPrelude
+
 data SDoc
 
 showSDocUnsafe :: SDoc -> String
diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs
index d816ad3f98..036dab062d 100644
--- a/compiler/utils/Pair.hs
+++ b/compiler/utils/Pair.hs
@@ -9,13 +9,16 @@ module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Outputable
+import qualified Data.Semigroup as Semi
 
 data Pair a = Pair { pFst :: a, pSnd :: a }
 -- Note that Pair is a *unary* type constructor
 -- whereas (,) is binary
 
--- The important thing about Pair is that it has a *homogenous*
+-- The important thing about Pair is that it has a *homogeneous*
 -- Functor instance, so you can easily apply the same function
 -- to both components
 instance Functor Pair where
@@ -31,9 +34,12 @@ instance Foldable Pair where
 instance Traversable Pair where
   traverse f (Pair x y) = Pair <$> f x <*> f y
 
-instance Monoid a => Monoid (Pair a) where
+instance Semi.Semigroup a => Semi.Semigroup (Pair a) where
+  Pair a1 b1 <> Pair a2 b2 =  Pair (a1 Semi.<> a2) (b1 Semi.<> b2)
+
+instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where
   mempty = Pair mempty mempty
-  Pair a1 b1 `mappend` Pair a2 b2 = Pair (a1 `mappend` a2) (b1 `mappend` b2)
+  mappend = (Semi.<>)
 
 instance Outputable a => Outputable (Pair a) where
   ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs
index 0a21f251fb..03f095b1a0 100644
--- a/compiler/utils/Panic.hs
+++ b/compiler/utils/Panic.hs
@@ -20,6 +20,8 @@ module Panic (
      panic, sorry, assertPanic, trace,
      panicDoc, sorryDoc, pgmErrorDoc,
 
+     cmdLineError, cmdLineErrorIO,
+
      Exception.Exception(..), showException, safeShowException,
      try, tryMost, throwTo,
 
@@ -27,6 +29,8 @@ module Panic (
 ) where
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
 
 import Config
@@ -193,8 +197,19 @@ panicDoc    x doc = throwGhcException (PprPanic        x doc)
 sorryDoc    x doc = throwGhcException (PprSorry        x doc)
 pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
 
+cmdLineError :: String -> a
+cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
+
+cmdLineErrorIO :: String -> IO a
+cmdLineErrorIO x = do
+  stack <- ccsToStrings =<< getCurrentCCS x
+  if null stack
+    then throwGhcException (CmdLineError x)
+    else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack))
+
+
 
--- | Throw an failed assertion exception for a given filename and line number.
+-- | Throw a failed assertion exception for a given filename and line number.
 assertPanic :: String -> Int -> a
 assertPanic file line =
   Exception.throw (Exception.AssertionFailed
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 7f749708b9..449a62a5b6 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -20,6 +20,8 @@ module Platform (
 
 where
 
+import GhcPrelude
+
 -- | Contains enough information for the native code generator to emit
 --      code for this platform.
 data Platform
@@ -75,7 +77,6 @@ data OS
         = OSUnknown
         | OSLinux
         | OSDarwin
-        | OSiOS
         | OSSolaris2
         | OSMinGW32
         | OSFreeBSD
@@ -85,8 +86,8 @@ data OS
         | OSKFreeBSD
         | OSHaiku
         | OSQNXNTO
-        | OSAndroid
         | OSAIX
+        | OSHurd
         deriving (Read, Show, Eq)
 
 -- | ARM Instruction Set Architecture, Extensions and ABI
@@ -131,13 +132,12 @@ osElfTarget OSOpenBSD   = True
 osElfTarget OSNetBSD    = True
 osElfTarget OSSolaris2  = True
 osElfTarget OSDarwin    = False
-osElfTarget OSiOS       = False
 osElfTarget OSMinGW32   = False
 osElfTarget OSKFreeBSD  = True
 osElfTarget OSHaiku     = True
 osElfTarget OSQNXNTO    = False
-osElfTarget OSAndroid   = True
 osElfTarget OSAIX       = False
+osElfTarget OSHurd      = True
 osElfTarget OSUnknown   = False
  -- Defaulting to False is safe; it means don't rely on any
  -- ELF-specific functionality.  It is important to have a default for
@@ -147,12 +147,10 @@ osElfTarget OSUnknown   = False
 -- | This predicate tells us whether the OS support Mach-O shared libraries.
 osMachOTarget :: OS -> Bool
 osMachOTarget OSDarwin = True
-osMachOTarget OSiOS    = True
 osMachOTarget _ = False
 
 osUsesFrameworks :: OS -> Bool
 osUsesFrameworks OSDarwin = True
-osUsesFrameworks OSiOS    = True
 osUsesFrameworks _        = False
 
 platformUsesFrameworks :: Platform -> Bool
@@ -160,6 +158,5 @@ platformUsesFrameworks = osUsesFrameworks . platformOS
 
 osSubsectionsViaSymbols :: OS -> Bool
 osSubsectionsViaSymbols OSDarwin = True
-osSubsectionsViaSymbols OSiOS    = True
 osSubsectionsViaSymbols _        = False
 
diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs
index ba7435d5c2..f32b8b0084 100644
--- a/compiler/utils/PprColour.hs
+++ b/compiler/utils/PprColour.hs
@@ -1,15 +1,21 @@
 module PprColour where
+import GhcPrelude
+
 import Data.Maybe (fromMaybe)
 import Util (OverridingBool(..), split)
+import Data.Semigroup as Semi
 
 -- | A colour\/style for use with 'coloured'.
 newtype PprColour = PprColour { renderColour :: String }
 
+instance Semi.Semigroup PprColour where
+  PprColour s1 <> PprColour s2 = PprColour (s1 <> s2)
+
 -- | Allow colours to be combined (e.g. bold + red);
 --   In case of conflict, right side takes precedence.
 instance Monoid PprColour where
   mempty = PprColour mempty
-  PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)
+  mappend = (<>)
 
 renderColourAfresh :: PprColour -> String
 renderColourAfresh c = renderColour (colReset `mappend` c)
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index a4d67f03a0..1a8bc23205 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -72,7 +72,7 @@ module Pretty (
 
         -- ** Converting values into documents
         char, text, ftext, ptext, ztext, sizedText, zeroWidthText,
-        int, integer, float, double, rational,
+        int, integer, float, double, rational, hex,
 
         -- ** Simple derived documents
         semi, comma, colon, space, equals,
@@ -103,7 +103,7 @@ module Pretty (
         Mode(..),
 
         -- ** General rendering
-        fullRender,
+        fullRender, txtPrinter,
 
         -- ** GHC-specific rendering
         printDoc, printDoc_,
@@ -111,14 +111,16 @@ module Pretty (
 
   ) where
 
+import GhcPrelude hiding (error)
+
 import BufWrite
 import FastString
 import Panic
 import System.IO
-import Prelude hiding (error)
+import Numeric (showHex)
 
 --for a RULES
-import GHC.Base ( unpackCString# )
+import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
 import GHC.Ptr  ( Ptr(..) )
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
@@ -268,8 +270,10 @@ data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment
                  | Str  String -- ^ A whole String fragment
                  | PStr FastString                      -- a hashed string
                  | ZStr FastZString                     -- a z-encoded string
-                 | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int
+                 | LStr {-# UNPACK #-} !LitString
                    -- a '\0'-terminated array of bytes
+                 | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char
+                   -- a repeated character (e.g., ' ')
 
 instance Show Doc where
   showsPrec _ doc cont = fullRender (mode style) (lineLength style)
@@ -294,25 +298,28 @@ char c = textBeside_ (Chr c) 1 Empty
 -- The side condition on the last law is necessary because @'text' \"\"@
 -- has height 1, while 'empty' has no height.
 text :: String -> Doc
-text s = case length s of {sl -> textBeside_ (Str s)  sl Empty}
+text s = textBeside_ (Str s) (length s) Empty
 {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
                             -- It must wait till after phase 1 when
                             -- the unpackCString first is manifested
 
 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
 -- intermediate packing/unpacking of the string.
-{-# RULES
-  "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
- #-}
+{-# RULES "text/str"
+    forall a. text (unpackCString# a)  = ptext (mkLitString# a)
+  #-}
+{-# RULES "text/unpackNBytes#"
+    forall p n. text (unpackNBytes# p n) = ptext (LitString (Ptr p) (I# n))
+  #-}
 
 ftext :: FastString -> Doc
-ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty}
+ftext s = textBeside_ (PStr s) (lengthFS s) Empty
 
 ptext :: LitString -> Doc
-ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty}
+ptext s = textBeside_ (LStr s) (lengthLS s) Empty
 
 ztext :: FastZString -> Doc
-ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty}
+ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty
 
 -- | Some text with any width. (@text s = sizedText (length s) s@)
 sizedText :: Int -> String -> Doc
@@ -334,12 +341,6 @@ isEmpty :: Doc -> Bool
 isEmpty Empty = True
 isEmpty _     = False
 
--- | Produce spacing for indenting the amount specified.
---
--- an old version inserted tabs being 8 columns apart in the output.
-spaces :: Int -> String
-spaces !n = replicate n ' '
-
 {-
 Q: What is the reason for negative indentation (i.e. argument to indent
    is < 0) ?
@@ -403,11 +404,18 @@ integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@
 float    :: Float    -> Doc -- ^ @float n = text (show n)@
 double   :: Double   -> Doc -- ^ @double n = text (show n)@
 rational :: Rational -> Doc -- ^ @rational n = text (show n)@
+hex      :: Integer  -> Doc -- ^ See Note [Print Hexadecimal Literals]
 int      n = text (show n)
 integer  n = text (show n)
 float    n = text (show n)
 double   n = text (show n)
 rational n = text (show n)
+hex      n = text ('0' : 'x' : padded)
+    where
+    str = showHex n ""
+    strLen = max 1 (length str)
+    len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int)
+    padded = replicate (len - strLen) '0' ++ str
 
 parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
 brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
@@ -422,6 +430,57 @@ parens p       = char '(' <> p <> char ')'
 brackets p     = char '[' <> p <> char ']'
 braces p       = char '{' <> p <> char '}'
 
+{-
+Note [Print Hexadecimal Literals]
+
+Relevant discussions:
+ * Phabricator: https://phabricator.haskell.org/D4465
+ * GHC Trac: https://ghc.haskell.org/trac/ghc/ticket/14872
+
+There is a flag `-dword-hex-literals` that causes literals of
+type `Word#` or `Word64#` to be displayed in hexadecimal instead
+of decimal when dumping GHC core. It also affects the presentation
+of these in GHC's error messages. Additionally, the hexadecimal
+encoding of these numbers is zero-padded so that its length is
+a power of two. As an example of what this does,
+consider the following haskell file `Literals.hs`:
+
+    module Literals where
+
+    alpha :: Int
+    alpha = 100 + 200
+
+    beta :: Word -> Word
+    beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202
+
+We get the following dumped core when we compile on a 64-bit
+machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all
+-dhex-word-literals literals.hs:
+
+    ==================== Tidy Core ====================
+
+    ... omitted for brevity ...
+
+    -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+    alpha
+    alpha = I# 300#
+
+    -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0}
+    beta
+    beta
+      = \ x_aYE ->
+          case x_aYE of { W# x#_a1v0 ->
+          W#
+            (plusWord#
+               (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##)
+               0x0202##)
+          }
+
+Notice that the word literals are in hexadecimals and that they have
+been padded with zeroes so that their lengths are 16, 8, and 4, respectively.
+
+-}
+
 -- | Apply 'parens' to 'Doc' if boolean is true.
 maybeParens :: Bool -> Doc -> Doc
 maybeParens False = id
@@ -432,8 +491,8 @@ maybeParens True = parens
 
 -- | Perform some simplification of a built up @GDoc@.
 reduceDoc :: Doc -> RDoc
-reduceDoc (Beside p g q) = beside p g (reduceDoc q)
-reduceDoc (Above  p g q) = above  p g (reduceDoc q)
+reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q)
+reduceDoc (Above  p g q) = p `seq` g `seq` (above  p g $! reduceDoc q)
 reduceDoc p              = p
 
 -- | List version of '<>'.
@@ -595,7 +654,7 @@ nilAboveNest _ _ Empty       = Empty
                                -- Here's why the "text s <>" is in the spec!
 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
 nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
-                             = textBeside_ (Str (spaces k)) k q
+                             = textBeside_ (RStr k ' ') k q
                              | otherwise           -- Put them really above
                              = nilAbove_ (mkNest k q)
 
@@ -878,11 +937,12 @@ renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
 
 -- | Default TextDetails printer
 txtPrinter :: TextDetails -> String -> String
-txtPrinter (Chr c)   s  = c:s
-txtPrinter (Str s1)  s2 = s1 ++ s2
-txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2
-txtPrinter (ZStr s1) s2 = zString s1 ++ s2
-txtPrinter (LStr s1 _) s2 = unpackLitString s1 ++ s2
+txtPrinter (Chr c)    s  = c:s
+txtPrinter (Str s1)   s2 = s1 ++ s2
+txtPrinter (PStr s1)  s2 = unpackFS s1 ++ s2
+txtPrinter (ZStr s1)  s2 = zString s1 ++ s2
+txtPrinter (LStr s1)  s2 = unpackLitString s1 ++ s2
+txtPrinter (RStr n c) s2 = replicate n c ++ s2
 
 -- | The general rendering interface.
 fullRender :: Mode                     -- ^ Rendering mode
@@ -968,10 +1028,7 @@ display m !page_width !ribbon_width txt end doc
         lay2 _ NoDoc               = error "display lay2 NoDoc"
         lay2 _ (Union {})          = error "display lay2 Union"
 
-        -- optimise long indentations using LitString chunks of 8 spaces
-        indent !n r | n >= 8    = LStr (sLit "        ") 8 `txt`
-                                  indent (n - 8) r
-                    | otherwise = Str (spaces n) `txt` r
+        indent !n r                = RStr n ' ' `txt` r
     in
     lay 0 doc
     }}
@@ -990,21 +1047,21 @@ printDoc_ mode pprCols hdl doc
   = do { fullRender mode pprCols 1.5 put done doc ;
          hFlush hdl }
   where
-    put (Chr c)  next = hPutChar hdl c >> next
-    put (Str s)  next = hPutStr  hdl s >> next
-    put (PStr s) next = hPutStr  hdl (unpackFS s) >> next
-                        -- NB. not hPutFS, we want this to go through
-                        -- the I/O library's encoding layer. (#3398)
-    put (ZStr s) next = hPutFZS  hdl s >> next
-    put (LStr s l) next = hPutLitString hdl s l >> next
+    put (Chr c)    next = hPutChar hdl c >> next
+    put (Str s)    next = hPutStr  hdl s >> next
+    put (PStr s)   next = hPutStr  hdl (unpackFS s) >> next
+                          -- NB. not hPutFS, we want this to go through
+                          -- the I/O library's encoding layer. (#3398)
+    put (ZStr s)   next = hPutFZS  hdl s >> next
+    put (LStr s)   next = hPutLitString hdl s >> next
+    put (RStr n c) next = hPutStr hdl (replicate n c) >> next
 
     done = return () -- hPutChar hdl '\n'
 
   -- some versions of hPutBuf will barf if the length is zero
-hPutLitString :: Handle -> Ptr a -> Int -> IO ()
-hPutLitString handle a l = if l == 0
-                            then return ()
-                            else hPutBuf handle a l
+hPutLitString :: Handle -> LitString -> IO ()
+hPutLitString _handle (LitString _ 0) = return ()
+hPutLitString handle  (LitString a l) = hPutBuf handle a l
 
 -- Printing output in LeftMode is performance critical: it's used when
 -- dumping C and assembly output, so we allow ourselves a few dirty
@@ -1031,18 +1088,19 @@ bufLeftRender b doc = layLeft b (reduceDoc doc)
 layLeft :: BufHandle -> Doc -> IO ()
 layLeft b _ | b `seq` False  = undefined -- make it strict in b
 layLeft _ NoDoc              = error "layLeft: NoDoc"
-layLeft b (Union p q)        = layLeft b (first p q)
-layLeft b (Nest _ p)         = layLeft b p
+layLeft b (Union p q)        = layLeft b $! first p q
+layLeft b (Nest _ p)         = layLeft b $! p
 layLeft b Empty              = bPutChar b '\n'
-layLeft b (NilAbove p)       = bPutChar b '\n' >> layLeft b p
-layLeft b (TextBeside s _ p) = put b s >> layLeft b p
+layLeft b (NilAbove p)       = p `seq` (bPutChar b '\n' >> layLeft b p)
+layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
  where
     put b _ | b `seq` False = undefined
     put b (Chr c)    = bPutChar b c
     put b (Str s)    = bPutStr  b s
     put b (PStr s)   = bPutFS   b s
     put b (ZStr s)   = bPutFZS  b s
-    put b (LStr s l) = bPutLitString b s l
+    put b (LStr s)   = bPutLitString b s
+    put b (RStr n c) = bPutReplicate b n c
 layLeft _ _                  = panic "layLeft: Unhandled case"
 
 -- Define error=panic, for easier comparison with libraries/pretty.
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index 8eca4657df..11bd7686d7 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -2,6 +2,8 @@
 
 module State where
 
+import GhcPrelude
+
 newtype State s a = State { runState' :: s -> (# a, s #) }
 
 instance Functor (State s) where
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
index f7b21017cf..ad01fad40c 100644
--- a/compiler/utils/Stream.hs
+++ b/compiler/utils/Stream.hs
@@ -11,6 +11,8 @@ module Stream (
     Stream.map, Stream.mapM, Stream.mapAccumL
   ) where
 
+import GhcPrelude
+
 import Control.Monad
 
 -- |
diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs
index d75e537fca..a5fc4e7f12 100644
--- a/compiler/utils/StringBuffer.hs
+++ b/compiler/utils/StringBuffer.hs
@@ -7,7 +7,7 @@ Buffers for scanning string input stored in external arrays.
 -}
 
 {-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O2 #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
 
@@ -45,6 +45,8 @@ module StringBuffer
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Encoding
 import FastString
 import FastFunctions
@@ -321,5 +323,6 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
   = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let
     go i x | i == len  = x
            | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of
+               '_'  -> go (i + 1) x    -- skip "_" (#14473)
                char -> go (i + 1) (x * radix + toInteger (char_to_int char))
   in go 0 0
diff --git a/compiler/utils/TrieMap.hs b/compiler/utils/TrieMap.hs
new file mode 100644
index 0000000000..917e3b21f6
--- /dev/null
+++ b/compiler/utils/TrieMap.hs
@@ -0,0 +1,405 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+module TrieMap(
+   -- * Maps over 'Maybe' values
+   MaybeMap,
+   -- * Maps over 'List' values
+   ListMap,
+   -- * Maps over 'Literal's
+   LiteralMap,
+   -- * 'TrieMap' class
+   TrieMap(..), insertTM, deleteTM,
+
+   -- * Things helpful for adding additional Instances.
+   (>.>), (|>), (|>>), XT,
+   foldMaybe,
+   -- * Map for leaf compression
+   GenMap,
+   lkG, xtG, mapG, fdG,
+   xtList, lkList
+
+ ) where
+
+import GhcPrelude
+
+import Literal
+import UniqDFM
+import Unique( Unique )
+
+import qualified Data.Map    as Map
+import qualified Data.IntMap as IntMap
+import Outputable
+import Control.Monad( (>=>) )
+
+{-
+This module implements TrieMaps, which are finite mappings
+whose key is a structured value like a CoreExpr or Type.
+
+This file implements tries over general data structures.
+Implementation for tries over Core Expressions/Types are
+available in coreSyn/TrieMap.
+
+The regular pattern for handling TrieMaps on data structures was first
+described (to my knowledge) in Connelly and Morris's 1995 paper "A
+generalization of the Trie Data Structure"; there is also an accessible
+description of the idea in Okasaki's book "Purely Functional Data
+Structures", Section 10.3.2
+
+************************************************************************
+*                                                                      *
+                   The TrieMap class
+*                                                                      *
+************************************************************************
+-}
+
+type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)
+                                --               or an existing elt (Just)
+
+class TrieMap m where
+   type Key m :: *
+   emptyTM  :: m a
+   lookupTM :: forall b. Key m -> m b -> Maybe b
+   alterTM  :: forall b. Key m -> XT b -> m b -> m b
+   mapTM    :: (a->b) -> m a -> m b
+
+   foldTM   :: (a -> b -> b) -> m a -> b -> b
+      -- The unusual argument order here makes
+      -- it easy to compose calls to foldTM;
+      -- see for example fdE below
+
+insertTM :: TrieMap m => Key m -> a -> m a -> m a
+insertTM k v m = alterTM k (\_ -> Just v) m
+
+deleteTM :: TrieMap m => Key m -> m a -> m a
+deleteTM k m = alterTM k (\_ -> Nothing) m
+
+----------------------
+-- Recall that
+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
+
+(>.>) :: (a -> b) -> (b -> c) -> a -> c
+-- Reverse function composition (do f first, then g)
+infixr 1 >.>
+(f >.> g) x = g (f x)
+infixr 1 |>, |>>
+
+(|>) :: a -> (a->b) -> b     -- Reverse application
+x |> f = f x
+
+----------------------
+(|>>) :: TrieMap m2
+      => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a))
+      -> (m2 a -> m2 a)
+      -> m1 (m2 a) -> m1 (m2 a)
+(|>>) f g = f (Just . g . deMaybe)
+
+deMaybe :: TrieMap m => Maybe (m a) -> m a
+deMaybe Nothing  = emptyTM
+deMaybe (Just m) = m
+
+{-
+************************************************************************
+*                                                                      *
+                   IntMaps
+*                                                                      *
+************************************************************************
+-}
+
+instance TrieMap IntMap.IntMap where
+  type Key IntMap.IntMap = Int
+  emptyTM = IntMap.empty
+  lookupTM k m = IntMap.lookup k m
+  alterTM = xtInt
+  foldTM k m z = IntMap.foldr k z m
+  mapTM f m = IntMap.map f m
+
+xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
+xtInt k f m = IntMap.alter f k m
+
+instance Ord k => TrieMap (Map.Map k) where
+  type Key (Map.Map k) = k
+  emptyTM = Map.empty
+  lookupTM = Map.lookup
+  alterTM k f m = Map.alter f k m
+  foldTM k m z = Map.foldr k z m
+  mapTM f m = Map.map f m
+
+
+{-
+Note [foldTM determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We want foldTM to be deterministic, which is why we have an instance of
+TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that
+go wrong if foldTM is nondeterministic. Consider:
+
+  f a b = return (a <> b)
+
+Depending on the order that the typechecker generates constraints you
+get either:
+
+  f :: (Monad m, Monoid a) => a -> a -> m a
+
+or:
+
+  f :: (Monoid a, Monad m) => a -> a -> m a
+
+The generated code will be different after desugaring as the dictionaries
+will be bound in different orders, leading to potential ABI incompatibility.
+
+One way to solve this would be to notice that the typeclasses could be
+sorted alphabetically.
+
+Unfortunately that doesn't quite work with this example:
+
+  f a b = let x = a <> a; y = b <> b in x
+
+where you infer:
+
+  f :: (Monoid m, Monoid m1) => m1 -> m -> m1
+
+or:
+
+  f :: (Monoid m1, Monoid m) => m1 -> m -> m1
+
+Here you could decide to take the order of the type variables in the type
+according to depth first traversal and use it to order the constraints.
+
+The real trouble starts when the user enables incoherent instances and
+the compiler has to make an arbitrary choice. Consider:
+
+  class T a b where
+    go :: a -> b -> String
+
+  instance (Show b) => T Int b where
+    go a b = show a ++ show b
+
+  instance (Show a) => T a Bool where
+    go a b = show a ++ show b
+
+  f = go 10 True
+
+GHC is free to choose either dictionary to implement f, but for the sake of
+determinism we'd like it to be consistent when compiling the same sources
+with the same flags.
+
+inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it
+gets converted to a bag of (Wanted) Cts using a fold. Then in
+solve_simple_wanteds it's merged with other WantedConstraints. We want the
+conversion to a bag to be deterministic. For that purpose we use UniqDFM
+instead of UniqFM to implement the TrieMap.
+
+See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made
+deterministic.
+-}
+
+instance TrieMap UniqDFM where
+  type Key UniqDFM = Unique
+  emptyTM = emptyUDFM
+  lookupTM k m = lookupUDFM m k
+  alterTM k f m = alterUDFM f m k
+  foldTM k m z = foldUDFM k z m
+  mapTM f m = mapUDFM f m
+
+{-
+************************************************************************
+*                                                                      *
+                   Maybes
+*                                                                      *
+************************************************************************
+
+If              m is a map from k -> val
+then (MaybeMap m) is a map from (Maybe k) -> val
+-}
+
+data MaybeMap m a = MM { mm_nothing  :: Maybe a, mm_just :: m a }
+
+instance TrieMap m => TrieMap (MaybeMap m) where
+   type Key (MaybeMap m) = Maybe (Key m)
+   emptyTM  = MM { mm_nothing = Nothing, mm_just = emptyTM }
+   lookupTM = lkMaybe lookupTM
+   alterTM  = xtMaybe alterTM
+   foldTM   = fdMaybe
+   mapTM    = mapMb
+
+mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
+mapMb f (MM { mm_nothing = mn, mm_just = mj })
+  = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
+
+lkMaybe :: (forall b. k -> m b -> Maybe b)
+        -> Maybe k -> MaybeMap m a -> Maybe a
+lkMaybe _  Nothing  = mm_nothing
+lkMaybe lk (Just x) = mm_just >.> lk x
+
+xtMaybe :: (forall b. k -> XT b -> m b -> m b)
+        -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a
+xtMaybe _  Nothing  f m = m { mm_nothing  = f (mm_nothing m) }
+xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f }
+
+fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b
+fdMaybe k m = foldMaybe k (mm_nothing m)
+            . foldTM k (mm_just m)
+
+{-
+************************************************************************
+*                                                                      *
+                   Lists
+*                                                                      *
+************************************************************************
+-}
+
+data ListMap m a
+  = LM { lm_nil  :: Maybe a
+       , lm_cons :: m (ListMap m a) }
+
+instance TrieMap m => TrieMap (ListMap m) where
+   type Key (ListMap m) = [Key m]
+   emptyTM  = LM { lm_nil = Nothing, lm_cons = emptyTM }
+   lookupTM = lkList lookupTM
+   alterTM  = xtList alterTM
+   foldTM   = fdList
+   mapTM    = mapList
+
+instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where
+  ppr m = text "List elts" <+> ppr (foldTM (:) m [])
+
+mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
+mapList f (LM { lm_nil = mnil, lm_cons = mcons })
+  = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
+
+lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
+        -> [k] -> ListMap m a -> Maybe a
+lkList _  []     = lm_nil
+lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs
+
+xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b)
+        -> [k] -> XT a -> ListMap m a -> ListMap m a
+xtList _  []     f m = m { lm_nil  = f (lm_nil m) }
+xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f }
+
+fdList :: forall m a b. TrieMap m
+       => (a -> b -> b) -> ListMap m a -> b -> b
+fdList k m = foldMaybe k          (lm_nil m)
+           . foldTM    (fdList k) (lm_cons m)
+
+foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
+foldMaybe _ Nothing  b = b
+foldMaybe k (Just a) b = k a b
+
+{-
+************************************************************************
+*                                                                      *
+                   Basic maps
+*                                                                      *
+************************************************************************
+-}
+
+type LiteralMap  a = Map.Map Literal a
+
+{-
+************************************************************************
+*                                                                      *
+                   GenMap
+*                                                                      *
+************************************************************************
+
+Note [Compressed TrieMap]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The GenMap constructor augments TrieMaps with leaf compression.  This helps
+solve the performance problem detailed in #9960: suppose we have a handful
+H of entries in a TrieMap, each with a very large key, size K. If you fold over
+such a TrieMap you'd expect time O(H). That would certainly be true of an
+association list! But with TrieMap we actually have to navigate down a long
+singleton structure to get to the elements, so it takes time O(K*H).  This
+can really hurt on many type-level computation benchmarks:
+see for example T9872d.
+
+The point of a TrieMap is that you need to navigate to the point where only one
+key remains, and then things should be fast.  So the point of a SingletonMap
+is that, once we are down to a single (key,value) pair, we stop and
+just use SingletonMap.
+
+'EmptyMap' provides an even more basic (but essential) optimization: if there is
+nothing in the map, don't bother building out the (possibly infinite) recursive
+TrieMap structure!
+
+Compressed triemaps are heavily used by CoreMap. So we have to mark some things
+as INLINEABLE to permit specialization.
+-}
+
+data GenMap m a
+   = EmptyMap
+   | SingletonMap (Key m) a
+   | MultiMap (m a)
+
+instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where
+  ppr EmptyMap = text "Empty map"
+  ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v
+  ppr (MultiMap m) = ppr m
+
+-- TODO undecidable instance
+instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
+   type Key (GenMap m) = Key m
+   emptyTM  = EmptyMap
+   lookupTM = lkG
+   alterTM  = xtG
+   foldTM   = fdG
+   mapTM    = mapG
+
+--We want to be able to specialize these functions when defining eg
+--tries over (GenMap CoreExpr) which requires INLINEABLE
+
+{-# INLINEABLE lkG #-}
+lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a
+lkG _ EmptyMap                         = Nothing
+lkG k (SingletonMap k' v') | k == k'   = Just v'
+                           | otherwise = Nothing
+lkG k (MultiMap m)                     = lookupTM k m
+
+{-# INLINEABLE xtG #-}
+xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a
+xtG k f EmptyMap
+    = case f Nothing of
+        Just v  -> SingletonMap k v
+        Nothing -> EmptyMap
+xtG k f m@(SingletonMap k' v')
+    | k' == k
+    -- The new key matches the (single) key already in the tree.  Hence,
+    -- apply @f@ to @Just v'@ and build a singleton or empty map depending
+    -- on the 'Just'/'Nothing' response respectively.
+    = case f (Just v') of
+        Just v'' -> SingletonMap k' v''
+        Nothing  -> EmptyMap
+    | otherwise
+    -- We've hit a singleton tree for a different key than the one we are
+    -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then
+    -- we can just return the old map. If not, we need a map with *two*
+    -- entries. The easiest way to do that is to insert two items into an empty
+    -- map of type @m a@.
+    = case f Nothing of
+        Nothing  -> m
+        Just v   -> emptyTM |> alterTM k' (const (Just v'))
+                           >.> alterTM k  (const (Just v))
+                           >.> MultiMap
+xtG k f (MultiMap m) = MultiMap (alterTM k f m)
+
+{-# INLINEABLE mapG #-}
+mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b
+mapG _ EmptyMap = EmptyMap
+mapG f (SingletonMap k v) = SingletonMap k (f v)
+mapG f (MultiMap m) = MultiMap (mapTM f m)
+
+{-# INLINEABLE fdG #-}
+fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
+fdG _ EmptyMap = \z -> z
+fdG k (SingletonMap _ v) = \z -> k v z
+fdG k (MultiMap m) = foldTM k m
diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs
index 228f3b5220..a2f3c687bb 100644
--- a/compiler/utils/UnVarGraph.hs
+++ b/compiler/utils/UnVarGraph.hs
@@ -24,14 +24,16 @@ module UnVarGraph
     , unionUnVarGraph, unionUnVarGraphs
     , completeGraph, completeBipartiteGraph
     , neighbors
+    , hasLoopAt
     , delNode
     ) where
 
+import GhcPrelude
+
 import Id
 import VarEnv
 import UniqFM
 import Outputable
-import Data.List
 import Bag
 import Unique
 
@@ -119,6 +121,13 @@ neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
         go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
                           (if v `elemUnVarSet` s2 then [s1] else [])
 
+-- hasLoopAt G v <=> v--v ∈ G
+hasLoopAt :: UnVarGraph -> Var -> Bool
+hasLoopAt (UnVarGraph g) v = any go $ bagToList g
+  where go (CG s)       = v `elemUnVarSet` s
+        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
+
+
 delNode :: UnVarGraph -> Var -> UnVarGraph
 delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
   where go (CG s)       = CG (s `delUnVarSet` v)
diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs
index 17f2747f83..38bf79df24 100644
--- a/compiler/utils/UniqDFM.hs
+++ b/compiler/utils/UniqDFM.hs
@@ -59,6 +59,8 @@ module UniqDFM (
         alwaysUnsafeUfmToUdfm,
     ) where
 
+import GhcPrelude
+
 import Unique           ( Uniquable(..), Unique, getKey )
 import Outputable
 
@@ -66,6 +68,7 @@ import qualified Data.IntMap as M
 import Data.Data
 import Data.List (sortBy)
 import Data.Function (on)
+import qualified Data.Semigroup as Semi
 import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap)
 
 -- Note [Deterministic UniqFM]
@@ -176,14 +179,14 @@ addToUDFM_C
 addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v
 
 addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt
-addListToUDFM = foldl (\m (k, v) -> addToUDFM m k v)
+addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)
 
 addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
-addListToUDFM_Directly = foldl (\m (k, v) -> addToUDFM_Directly m k v)
+addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)
 
 addListToUDFM_Directly_C
   :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt
-addListToUDFM_Directly_C f = foldl (\m (k, v) -> addToUDFM_Directly_C f m k v)
+addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v)
 
 delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt
 delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
@@ -326,7 +329,7 @@ partitionUDFM p (UDFM m i) =
 
 -- | Delete a list of elements from a UniqDFM
 delListFromUDFM  :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt
-delListFromUDFM = foldl delFromUDFM
+delListFromUDFM = foldl' delFromUDFM
 
 -- | This allows for lossy conversion from UniqDFM to UniqFM
 udfmToUfm :: UniqDFM elt -> UniqFM elt
@@ -334,10 +337,10 @@ udfmToUfm (UDFM m _i) =
   listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]
 
 listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt
-listToUDFM = foldl (\m (k, v) -> addToUDFM m k v) emptyUDFM
+listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
 
 listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt
-listToUDFM_Directly = foldl (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
+listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
 
 -- | Apply a function to a particular element
 adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt
@@ -371,9 +374,12 @@ anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
 allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool
 allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m
 
+instance Semi.Semigroup (UniqDFM a) where
+  (<>) = plusUDFM
+
 instance Monoid (UniqDFM a) where
   mempty = emptyUDFM
-  mappend = plusUDFM
+  mappend = (Semi.<>)
 
 -- This should not be used in commited code, provided for convenience to
 -- make ad-hoc conversions when developing
diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs
index eef545eedd..0f81a5bc1a 100644
--- a/compiler/utils/UniqDSet.hs
+++ b/compiler/utils/UniqDSet.hs
@@ -32,6 +32,8 @@ module UniqDSet (
         partitionUniqDSet
     ) where
 
+import GhcPrelude
+
 import UniqDFM
 import UniqSet
 import Unique
@@ -45,13 +47,13 @@ unitUniqDSet :: Uniquable a => a -> UniqDSet a
 unitUniqDSet x = unitUDFM x x
 
 mkUniqDSet :: Uniquable a => [a]  -> UniqDSet a
-mkUniqDSet = foldl addOneToUniqDSet emptyUniqDSet
+mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet
 
 addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a
 addOneToUniqDSet set x = addToUDFM set x x
 
 addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a
-addListToUniqDSet = foldl addOneToUniqDSet
+addListToUniqDSet = foldl' addOneToUniqDSet
 
 delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a
 delOneFromUniqDSet = delFromUDFM
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 71a092b28e..d4a024d34c 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -20,7 +20,6 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
 of arguments of combining function.
 -}
 
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wall #-}
@@ -71,28 +70,20 @@ module UniqFM (
         pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM
     ) where
 
+import GhcPrelude
+
 import Unique           ( Uniquable(..), Unique, getKey )
 import Outputable
 
-import Data.List (foldl')
-
 import qualified Data.IntMap as M
-#if MIN_VERSION_containers(0,5,9)
-import qualified Data.IntMap.Merge.Lazy as M
-import Control.Applicative (Const (..))
-import qualified Data.Monoid as Mon
-#endif
 import qualified Data.IntSet as S
-import Data.Typeable
 import Data.Data
-#if __GLASGOW_HASKELL__ > 710
-import Data.Semigroup   ( Semigroup )
-import qualified Data.Semigroup as Semigroup
-#endif
+import qualified Data.Semigroup as Semi
+import Data.Functor.Classes (Eq1 (..))
 
 
 newtype UniqFM ele = UFM (M.IntMap ele)
-  deriving (Data, Eq, Functor, Typeable)
+  deriving (Data, Eq, Functor)
   -- We used to derive Traversable and Foldable, but they were nondeterministic
   -- and not obvious at the call site. You can use explicit nonDetEltsUFM
   -- and fold a list if needed.
@@ -112,26 +103,26 @@ unitDirectlyUFM :: Unique -> elt -> UniqFM elt
 unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
 
 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
-listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
+listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM
 
 listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt
-listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
+listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
 
 listToUFM_C
   :: Uniquable key
   => (elt -> elt -> elt)
   -> [(key, elt)]
   -> UniqFM elt
-listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
+listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM
 
 addToUFM :: Uniquable key => UniqFM elt -> key -> elt  -> UniqFM elt
 addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
 
 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
-addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
+addListToUFM = foldl' (\m (k, v) -> addToUFM m k v)
 
 addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
-addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
+addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v)
 
 addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt
 addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
@@ -169,7 +160,7 @@ addListToUFM_C
   => (elt -> elt -> elt)
   -> UniqFM elt -> [(key,elt)]
   -> UniqFM elt
-addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
+addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v)
 
 adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
 adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
@@ -181,10 +172,10 @@ delFromUFM :: Uniquable key => UniqFM elt -> key    -> UniqFM elt
 delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
 
 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
-delListFromUFM = foldl delFromUFM
+delListFromUFM = foldl' delFromUFM
 
 delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt
-delListFromUFM_Directly = foldl delFromUFM_Directly
+delListFromUFM_Directly = foldl' delFromUFM_Directly
 
 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
@@ -347,25 +338,16 @@ ufmToIntMap (UFM m) = m
 
 -- Determines whether two 'UniqFm's contain the same keys.
 equalKeysUFM :: UniqFM a -> UniqFM b -> Bool
-#if MIN_VERSION_containers(0,5,9)
-equalKeysUFM (UFM m1) (UFM m2) = Mon.getAll $ getConst $
-      M.mergeA (M.traverseMissing (\_ _ -> Const (Mon.All False)))
-               (M.traverseMissing (\_ _ -> Const (Mon.All False)))
-               (M.zipWithAMatched (\_ _ _ -> Const (Mon.All True))) m1 m2
-#else
-equalKeysUFM (UFM m1) (UFM m2) = M.keys m1 == M.keys m2
-#endif
+equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2
 
 -- Instances
 
-#if __GLASGOW_HASKELL__ > 710
-instance Semigroup (UniqFM a) where
+instance Semi.Semigroup (UniqFM a) where
   (<>) = plusUFM
-#endif
 
 instance Monoid (UniqFM a) where
     mempty = emptyUFM
-    mappend = plusUFM
+    mappend = (Semi.<>)
 
 -- Output-ery
 
diff --git a/compiler/utils/UniqMap.hs b/compiler/utils/UniqMap.hs
index 012409b8c2..1bd51c2b38 100644
--- a/compiler/utils/UniqMap.hs
+++ b/compiler/utils/UniqMap.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# OPTIONS_GHC -Wall #-}
@@ -45,32 +44,29 @@ module UniqMap (
     -- Non-deterministic functions omitted
 ) where
 
+import GhcPrelude
+
 import UniqFM
 
 import Unique
 import Outputable
 
-#if __GLASGOW_HASKELL__ > 710
-import Data.Semigroup   ( Semigroup(..) )
-#endif
+import Data.Semigroup as Semi ( Semigroup(..) )
 import Data.Coerce
 import Data.Maybe
-import Data.Typeable
 import Data.Data
 
 -- | Maps indexed by 'Uniquable' keys
 newtype UniqMap k a = UniqMap (UniqFM (k, a))
-    deriving (Data, Eq, Functor, Typeable)
+    deriving (Data, Eq, Functor)
 type role UniqMap nominal representational
 
-#if __GLASGOW_HASKELL__ > 710
 instance Semigroup (UniqMap k a) where
   (<>) = plusUniqMap
-#endif
 
 instance Monoid (UniqMap k a) where
     mempty = emptyUniqMap
-    mappend = plusUniqMap
+    mappend = (Semi.<>)
 
 instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where
     ppr (UniqMap m) =
diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs
index f29a1e6e1f..be600a09b3 100644
--- a/compiler/utils/UniqSet.hs
+++ b/compiler/utils/UniqSet.hs
@@ -9,7 +9,6 @@ Based on @UniqFMs@ (as you would expect).
 Basically, the things need to be in class @Uniquable@.
 -}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module UniqSet (
@@ -47,15 +46,15 @@ module UniqSet (
         nonDetFoldUniqSet_Directly
     ) where
 
+import GhcPrelude
+
 import UniqFM
 import Unique
 import Data.Coerce
 import Outputable
 import Data.Foldable (foldl')
 import Data.Data
-#if __GLASGOW_HASKELL__ >= 801
-import qualified Data.Semigroup
-#endif
+import qualified Data.Semigroup as Semi
 
 -- Note [UniqSet invariant]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -64,7 +63,8 @@ import qualified Data.Semigroup
 -- It means that to implement mapUniqSet you have to update
 -- both the keys and the values.
 
-newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} deriving Data
+newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a}
+                  deriving (Data, Semi.Semigroup, Monoid)
 
 emptyUniqSet :: UniqSet a
 emptyUniqSet = UniqSet emptyUFM
@@ -189,13 +189,6 @@ unsafeUFMToUniqSet = UniqSet
 
 instance Outputable a => Outputable (UniqSet a) where
     ppr = pprUniqSet ppr
-#if __GLASGOW_HASKELL__ >= 801
-instance Data.Semigroup.Semigroup (UniqSet a) where
-  (<>) = mappend
-#endif
-instance Monoid (UniqSet a) where
-  mempty = UniqSet mempty
-  UniqSet s `mappend` UniqSet t = UniqSet (s `mappend` t)
 
 pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc
 pprUniqSet f (UniqSet s) = pprUniqFM f s
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 35a6340fd4..9523c08ff2 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -4,11 +4,6 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE BangPatterns #-}
-#if __GLASGOW_HASKELL__ < 800
--- For CallStack business
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE FlexibleContexts #-}
-#endif
 
 -- | Highly random utility functions
 --
@@ -30,7 +25,7 @@ module Util (
 
         mapFst, mapSnd, chkAppend,
         mapAndUnzip, mapAndUnzip3, mapAccumL2,
-        nOfThem, filterOut, partitionWith, splitEithers,
+        nOfThem, filterOut, partitionWith,
 
         dropWhileEndLE, spanEnd,
 
@@ -94,6 +89,7 @@ module Util (
 
         -- * Floating point
         readRational,
+        readHexRational,
 
         -- * read helpers
         maybeRead, maybeReadFuzzy,
@@ -102,7 +98,6 @@ module Util (
         doesDirNameExist,
         getModificationUTCTime,
         modificationTimeIfExists,
-        hSetTranslit,
 
         global, consIORef, globalM,
         sharedGlobal, sharedGlobalM,
@@ -124,12 +119,8 @@ module Util (
         hashString,
 
         -- * Call stacks
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-        GHC.Stack.CallStack,
-#endif
         HasCallStack,
         HasDebugCallStack,
-        prettyCurrentCallStack,
 
         -- * Utils for flags
         OverridingBool(..),
@@ -138,6 +129,8 @@ module Util (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import Exception
 import Panic
 
@@ -147,18 +140,17 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Data.List        hiding (group)
 
 import GHC.Exts
-import qualified GHC.Stack
+import GHC.Stack (HasCallStack)
 
 import Control.Applicative ( liftA2 )
-import Control.Monad    ( liftM )
-import GHC.IO.Encoding (mkTextEncoding, textEncodingName)
+import Control.Monad    ( liftM, guard )
 import GHC.Conc.Sync ( sharedCAF )
-import System.IO (Handle, hGetEncoding, hSetEncoding)
 import System.IO.Error as IO ( isDoesNotExistError )
 import System.Directory ( doesDirectoryExist, getModificationTime )
 import System.FilePath
 
-import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper)
+import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper
+                        , isHexDigit, digitToInt )
 import Data.Int
 import Data.Ratio       ( (%) )
 import Data.Ord         ( comparing )
@@ -301,14 +293,6 @@ partitionWith f (x:xs) = case f x of
                          Right c -> (bs, c:cs)
     where (bs,cs) = partitionWith f xs
 
-splitEithers :: [Either a b] -> ([a], [b])
--- ^ Teases a list of 'Either's apart into two lists
-splitEithers [] = ([],[])
-splitEithers (e : es) = case e of
-                        Left x -> (x:xs, ys)
-                        Right y -> (xs, y:ys)
-    where (xs,ys) = splitEithers es
-
 chkAppend :: [a] -> [a] -> [a]
 -- Checks for the second argument being empty
 -- Used in situations where that situation is common
@@ -1147,12 +1131,18 @@ readRational__ r = do
 
      lexDecDigits = nonnull isDigit
 
-     lexDotDigits ('.':s) = return (span isDigit s)
+     lexDotDigits ('.':s) = return (span' isDigit s)
      lexDotDigits s       = return ("",s)
 
-     nonnull p s = do (cs@(_:_),t) <- return (span p s)
+     nonnull p s = do (cs@(_:_),t) <- return (span' p s)
                       return (cs,t)
 
+     span' _ xs@[]         =  (xs, xs)
+     span' p xs@(x:xs')
+               | x == '_'  = span' p xs'   -- skip "_" (#14473)
+               | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
+               | otherwise =  ([],xs)
+
 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 readRational top_s
   = case top_s of
@@ -1166,6 +1156,64 @@ readRational top_s
           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 
 
+readHexRational :: String -> Rational
+readHexRational str =
+  case str of
+    '-' : xs -> - (readMe xs)
+    xs       -> readMe xs
+  where
+  readMe as =
+    case readHexRational__ as of
+      Just n -> n
+      _      -> error ("readHexRational: no parse:" ++ str)
+
+
+readHexRational__ :: String -> Maybe Rational
+readHexRational__ ('0' : x : rest)
+  | x == 'X' || x == 'x' =
+  do let (front,rest2) = span' isHexDigit rest
+     guard (not (null front))
+     let frontNum = steps 16 0 front
+     case rest2 of
+       '.' : rest3 ->
+          do let (back,rest4) = span' isHexDigit rest3
+             guard (not (null back))
+             let backNum = steps 16 frontNum back
+                 exp1    = -4 * length back
+             case rest4 of
+               p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)
+               _ -> return (mk backNum exp1)
+       p : ps | isExp p -> fmap (mk frontNum) (getExp ps)
+       _ -> Nothing
+
+  where
+  isExp p = p == 'p' || p == 'P'
+
+  getExp ('+' : ds) = dec ds
+  getExp ('-' : ds) = fmap negate (dec ds)
+  getExp ds         = dec ds
+
+  mk :: Integer -> Int -> Rational
+  mk n e = fromInteger n * 2^^e
+
+  dec cs = case span' isDigit cs of
+             (ds,"") | not (null ds) -> Just (steps 10 0 ds)
+             _ -> Nothing
+
+  steps base n ds = foldl' (step base) n ds
+  step  base n d  = base * n + fromIntegral (digitToInt d)
+
+  span' _ xs@[]         =  (xs, xs)
+  span' p xs@(x:xs')
+            | x == '_'  = span' p xs'   -- skip "_"  (#14473)
+            | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)
+            | otherwise =  ([],xs)
+
+readHexRational__ _ = Nothing
+
+
+
+
 -----------------------------------------------------------------------------
 -- read helpers
 
@@ -1205,18 +1253,6 @@ modificationTimeIfExists f = do
                         else ioError e
 
 -- --------------------------------------------------------------
--- Change the character encoding of the given Handle to transliterate
--- on unsupported characters instead of throwing an exception
-
-hSetTranslit :: Handle -> IO ()
-hSetTranslit h = do
-    menc <- hGetEncoding h
-    case fmap textEncodingName menc of
-        Just name | '/' `notElem` name -> do
-            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
-            hSetEncoding h enc'
-        _ -> return ()
-
 -- split a string at the last character where 'pred' is True,
 -- returning a pair of strings. The first component holds the string
 -- up (but not including) the last character for which 'pred' returned
@@ -1368,16 +1404,6 @@ mulHi a b = fromIntegral (r `shiftR` 32)
    where r :: Int64
          r = fromIntegral a * fromIntegral b
 
--- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.
-#if __GLASGOW_HASKELL__ >= 800
-type HasCallStack = GHC.Stack.HasCallStack
-#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-type HasCallStack = (?callStack :: GHC.Stack.CallStack)
--- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
-#else
-type HasCallStack = (() :: Constraint)
-#endif
-
 -- | A call stack constraint, but only when 'isDebugOn'.
 #if defined(DEBUG)
 type HasDebugCallStack = HasCallStack
@@ -1385,18 +1411,6 @@ type HasDebugCallStack = HasCallStack
 type HasDebugCallStack = (() :: Constraint)
 #endif
 
--- | Pretty-print the current callstack
-#if __GLASGOW_HASKELL__ >= 800
-prettyCurrentCallStack :: HasCallStack => String
-prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack
-#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
-prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String
-prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
-#else
-prettyCurrentCallStack :: HasCallStack => String
-prettyCurrentCallStack = "Call stack unavailable"
-#endif
-
 data OverridingBool
   = Auto
   | Always
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
deleted file mode 100644
index 2e09adbbbe..0000000000
--- a/compiler/vectorise/Vectorise.hs
+++ /dev/null
@@ -1,356 +0,0 @@
--- Main entry point to the vectoriser.  It is invoked iff the option '-fvectorise' is passed.
---
--- This module provides the function 'vectorise', which vectorises an entire (desugared) module.
--- It vectorises all type declarations and value bindings.  It also processes all VECTORISE pragmas
--- (aka vectorisation declarations), which can lead to the vectorisation of imported data types
--- and the enrichment of imported functions with vectorised versions.
-
-module Vectorise ( vectorise )
-where
-
-import Vectorise.Type.Env
-import Vectorise.Type.Type
-import Vectorise.Convert
-import Vectorise.Utils.Hoisting
-import Vectorise.Exp
-import Vectorise.Env
-import Vectorise.Monad
-
-import HscTypes hiding      ( MonadThings(..) )
-import CoreUnfold           ( mkInlineUnfoldingWithArity )
-import PprCore
-import CoreSyn
-import CoreMonad            ( CoreM, getHscEnv )
-import Type
-import Id
-import DynFlags
-import Outputable
-import Util                 ( zipLazy )
-import MonadUtils
-
-import Control.Monad
-
-
--- |Vectorise a single module.
---
-vectorise :: ModGuts -> CoreM ModGuts
-vectorise guts
- = do { hsc_env <- getHscEnv
-      ; liftIO $ vectoriseIO hsc_env guts
-      }
-
--- Vectorise a single monad, given the dynamic compiler flags and HscEnv.
---
-vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts
-vectoriseIO hsc_env guts
- = do {   -- Get information about currently loaded external packages.
-      ; eps <- hscEPS hsc_env
-
-          -- Combine vectorisation info from the current module, and external ones.
-      ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
-
-          -- Run the main VM computation.
-      ; Just (info', guts') <- initV hsc_env guts info (vectModule guts)
-      ; return (guts' { mg_vect_info = info' })
-      }
-
--- Vectorise a single module, in the VM monad.
---
-vectModule :: ModGuts -> VM ModGuts
-vectModule guts@(ModGuts { mg_tcs        = tycons
-                         , mg_binds      = binds
-                         , mg_fam_insts  = fam_insts
-                         , mg_vect_decls = vect_decls
-                         })
- = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $
-          pprCoreBindings binds
-
-          -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas
-      ; let ty_vect_decls  = [vd | vd@(VectType _ _ _) <- vect_decls]
-            cls_vect_decls = [vd | vd@(VectClass _)    <- vect_decls]
-
-          -- Vectorise the type environment.  This will add vectorised
-          -- type constructors, their representations, and the
-          -- corresponding data constructors.  Moreover, we produce
-          -- bindings for dfuns and family instances of the classes
-          -- and type families used in the DPH library to represent
-          -- array types.
-      ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls
-
-          -- Family instance environment for /all/ home-package modules including those instances
-          -- generated by 'vectTypeEnv'.
-      ; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-
-          -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
-          -- NB: Need to vectorise the imported bindings first (local bindings may depend on them).
-      ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id]
-      ; binds_imp <- mapM vectImpBind impBinds
-      ; binds_top <- mapM vectTopBind binds
-
-      ; return $ guts { mg_tcs          = tycons ++ new_tycons
-                        -- we produce no new classes or instances, only new class type constructors
-                        -- and dfuns
-                      , mg_binds        = Rec tc_binds : (binds_top ++ binds_imp)
-                      , mg_fam_inst_env = fam_inst_env
-                      , mg_fam_insts    = fam_insts ++ new_fam_insts
-                      }
-      }
-
--- Try to vectorise a top-level binding.  If it doesn't vectorise, or if it is entirely scalar, then
--- omit vectorisation of that binding.
---
--- For example, for the binding
---
--- @
---    foo :: Int -> Int
---    foo = \x -> x + x
--- @
---
--- we get
--- @
---    foo  :: Int -> Int
---    foo  = \x -> vfoo $: x
---
---    v_foo :: Closure void vfoo lfoo
---    v_foo = closure vfoo lfoo void
---
---    vfoo :: Void -> Int -> Int
---    vfoo = ...
---
---    lfoo :: PData Void -> PData Int -> PData Int
---    lfoo = ...
--- @
---
--- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo,
--- but takes an explicit environment.
---
--- @lfoo@ is the "lifted" version that works on arrays.
---
--- @v_foo@ combines both of these into a `Closure` that also contains the environment.
---
--- The original binding @foo@ is rewritten to call the vectorised version present in the closure.
---
--- Vectorisation may be suppressed by annotating a binding with a 'NOVECTORISE' pragma.  If this
--- pragma is used in a group of mutually recursive bindings, either all or no binding must have
--- the pragma.  If only some bindings are annotated, a fatal error is being raised. (In the case of
--- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.)
---
--- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or
---   we may emit a warning and refrain from vectorising the entire group.
---
-vectTopBind :: CoreBind -> VM CoreBind
-vectTopBind b@(NonRec var expr)
-  = do
-    { traceVt "= Vectorise non-recursive top-level variable" (ppr var)
-
-    ; (hasNoVect, vectDecl) <- lookupVectDecl var
-    ; if hasNoVect
-      then do
-      {   -- 'NOVECTORISE' pragma => leave this binding as it is
-      ; traceVt "NOVECTORISE" $ ppr var
-      ; return b
-      }
-      else do
-    { vectRhs <- case vectDecl of
-        Just (_, expr') ->
-            -- 'VECTORISE' pragma => just use the provided vectorised rhs
-          do
-          { traceVt "VECTORISE" $ ppr var
-          ; addGlobalParallelVar var
-          ; return $ Just (False, inlineMe, expr')
-          }
-        Nothing         ->
-            -- no pragma => standard vectorisation of rhs
-          do
-          { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr
-          ; vectTopExpr var expr
-          }
-    ; hs <- takeHoisted -- make sure we clean those out (even if we skip)
-    ; case vectRhs of
-      { Nothing ->
-          -- scalar binding => leave this binding as it is
-          do
-          { traceVt "scalar binding [skip]" $ ppr var
-          ; return b
-          }
-      ; Just (parBind, inline, expr') -> do
-    {
-       -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map
-    ; when parBind $
-        addGlobalParallelVar var
-    ; var' <- vectTopBinder var inline expr'
-
-        -- We replace the original top-level binding by a value projected from the vectorised
-        -- closure and add any newly created hoisted top-level bindings.
-    ; cexpr <- tryConvert var var' expr
-    ; return . Rec $ (var, cexpr) : (var', expr') : hs
-    } } } }
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT vectorise top-level binding" $ ppr var
-    ; return b
-    }
-vectTopBind b@(Rec binds)
-  = do
-    { traceVt "= Vectorise recursive top-level variables" $ ppr vars
-
-    ; vectDecls <- mapM lookupVectDecl vars
-    ; let hasNoVects = map fst vectDecls
-    ; if and hasNoVects
-      then do
-      {   -- 'NOVECTORISE' pragmas => leave this entire binding group as it is
-      ; traceVt "NOVECTORISE" $ ppr vars
-      ; return b
-      }
-      else do
-    { if or hasNoVects
-      then do
-        {   -- Inconsistent 'NOVECTORISE' pragmas => bail out
-        ; dflags <- getDynFlags
-        ; cantVectorise dflags noVectoriseErr (ppr b)
-        }
-      else do
-    { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds]
-
-       -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression
-    ; newBindsWPragma  <- concat <$>
-                          sequence [ vectTopBindAndConvert bind inlineMe expr'
-                                   | (bind, (_, Just (_, expr'))) <- zip binds vectDecls]
-
-        -- Standard vectorisation of all rhses that are *without* a pragma.
-        -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for
-        --     the bound variables in the recursive group to the vectorisation map, which in turn
-        --     are needed by 'vectPolyExprs' (unless it returns 'Nothing').
-    ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls]
-    ; (newBinds, _) <- fixV $
-        \ ~(_, exprs') ->
-          do
-          {   -- Create appropriate top-level bindings, enter them into the vectorisation map, and
-              -- vectorise the right-hand sides
-          ; newBindsWOPragma <- concat <$>
-                                sequence [vectTopBindAndConvert bind inline expr
-                                         | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs']
-                                         -- irrefutable pattern and 'zipLazy' to tie the knot;
-                                         -- hence, can't use 'zipWithM'
-          ; vectRhses <- vectTopExprs bindsWOPragma
-          ; hs <- takeHoisted -- make sure we clean those out (even if we skip)
-
-          ; case vectRhses of
-              Nothing ->
-                -- scalar bindings => skip all bindings except those with pragmas and retract the
-                --   entries into the vectorisation map for the scalar bindings
-                do
-                { traceVt "scalar bindings [skip]" $ ppr vars
-                ; mapM_ (undefGlobalVar . fst) bindsWOPragma
-                ; return (bindsWOPragma ++ newBindsWPragma, exprs')
-                }
-              Just (parBind, exprs') ->
-                -- vanilla case => record parallel variables and return the final bindings
-                do
-                { when parBind $
-                    mapM_ addGlobalParallelVar vars
-                ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs')
-                }
-          }
-    ; return $ Rec newBinds
-    } } }
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT vectorise top-level bindings" $ ppr vars
-    ; return b
-    }
-  where
-    vars = map fst binds
-    noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group"
-
-    -- Replace the original top-level bindings by a values projected from the vectorised
-    -- closures and add any newly created hoisted top-level bindings to the group.
-    vectTopBindAndConvert (var, expr) inline expr'
-      = do
-        { var'  <- vectTopBinder var inline expr'
-        ; cexpr <- tryConvert var var' expr
-        ; return [(var, cexpr), (var', expr')]
-        }
-
--- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma
--- in this module.
---
--- RESTRICTION: Currently, we cannot use the pragma for mutually recursive definitions.
---
-vectImpBind :: (Id, CoreExpr) -> VM CoreBind
-vectImpBind (var, expr)
-  = do
-    { traceVt "= Add vectorised binding to imported variable" (ppr var)
-
-    ; var' <- vectTopBinder var inlineMe expr
-    ; return $ NonRec var' expr
-    }
-
--- |Make the vectorised version of this top level binder, and add the mapping between it and the
--- original to the state. For some binder @foo@ the vectorised version is @$v_foo@
---
--- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of
---       'fixV' in 'vectTopBind'.
---
-vectTopBinder :: Var      -- ^ Name of the binding.
-              -> Inline   -- ^ Whether it should be inlined, used to annotate it.
-              -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'.
-              -> VM Var   -- ^ Name of the vectorised binding.
-vectTopBinder var inline expr
- = do {   -- Vectorise the type attached to the var.
-      ; vty  <- vectType (idType var)
-
-          -- If there is a vectorisation declaration for this binding, make sure its type matches
-      ; (_, vectDecl) <- lookupVectDecl var
-      ; case vectDecl of
-          Nothing             -> return ()
-          Just (vdty, _)
-            | eqType vty vdty -> return ()
-            | otherwise       ->
-              do
-              { dflags <- getDynFlags
-              ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
-                  (text "Expected type" <+> ppr vty)
-                  $$
-                  (text "Inferred type" <+> ppr vdty)
-              }
-          -- Make the vectorised version of binding's name, and set the unfolding used for inlining
-      ; var' <- liftM (`setIdUnfolding` unfolding)
-                $  mkVectId var vty
-
-          -- Add the mapping between the plain and vectorised name to the state.
-      ; defGlobalVar var var'
-
-      ; return var'
-    }
-  where
-    unfolding = case inline of
-                  Inline arity -> mkInlineUnfoldingWithArity arity expr
-                  DontInline   -> noUnfolding
-{-
-!!!TODO: dfuns and unfoldings:
-           -- Do not inline the dfun; instead give it a magic DFunFunfolding
-           -- See Note [ClassOp/DFun selection]
-           -- See also note [Single-method classes]
-        dfun_id_w_fun
-           | isNewTyCon class_tc
-           = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
-           | otherwise
-           = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
-                     `setInlinePragma` dfunInlinePragma
- -}
-
--- |Project out the vectorised version of a binding from some closure, or return the original body
--- if that doesn't work.
---
-tryConvert :: Var       -- ^Name of the original binding (eg @foo@)
-           -> Var       -- ^Name of vectorised version of binding (eg @$vfoo@)
-           -> CoreExpr  -- ^The original body of the binding.
-           -> VM CoreExpr
-tryConvert var vect_var rhs
-  = fromVect (idType var) (Var vect_var)
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var)
-    ; return rhs
-    }
diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs
deleted file mode 100644
index 7fe5b2cecc..0000000000
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser.
---
--- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that
--- appear in code generated by the vectoriser.
-
-module Vectorise.Builtins (
-  -- * Restrictions
-  mAX_DPH_SCALAR_ARGS,
-
-  -- * Builtins
-  Builtins(..),
-
-  -- * Wrapped selectors
-  selTy, selsTy,
-  selReplicate,
-  selTags,
-  selElements,
-  selsLength,
-  sumTyCon,
-  prodTyCon,
-  prodDataCon,
-  replicatePD_PrimVar,
-  emptyPD_PrimVar,
-  packByTagPD_PrimVar,
-  combinePDVar,
-  combinePD_PrimVar,
-  scalarZip,
-  closureCtrFun,
-
-  -- * Initialisation
-  initBuiltins, initBuiltinVars,
-) where
-
-import Vectorise.Builtins.Base
-import Vectorise.Builtins.Initialise
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
deleted file mode 100644
index 4837bde208..0000000000
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ /dev/null
@@ -1,217 +0,0 @@
--- |Builtin types and functions used by the vectoriser. These are all defined in
--- 'Data.Array.Parallel.Prim'.
-
-module Vectorise.Builtins.Base (
-  -- * Hard config
-  mAX_DPH_PROD,
-  mAX_DPH_SUM,
-  mAX_DPH_COMBINE,
-  mAX_DPH_SCALAR_ARGS,
-  aLL_DPH_PRIM_TYCONS,
-
-  -- * Builtins
-  Builtins(..),
-
-  -- * Projections
-  selTy, selsTy,
-  selReplicate,
-  selTags,
-  selElements,
-  selsLength,
-  sumTyCon,
-  prodTyCon,
-  prodDataCon,
-  replicatePD_PrimVar,
-  emptyPD_PrimVar,
-  packByTagPD_PrimVar,
-  combinePDVar,
-  combinePD_PrimVar,
-  scalarZip,
-  closureCtrFun
-) where
-
-import TysPrim
-import BasicTypes
-import Class
-import CoreSyn
-import TysWiredIn hiding (sumTyCon)
-import Type
-import TyCon
-import DataCon
-import NameEnv
-import Name
-import Outputable
-
-import Data.Array
-
-
--- Cardinality of the various families of types and functions exported by the DPH library.
-
-mAX_DPH_PROD :: Int
-mAX_DPH_PROD = 5
-
-mAX_DPH_SUM :: Int
-mAX_DPH_SUM = 2
-
-mAX_DPH_COMBINE :: Int
-mAX_DPH_COMBINE = 2
-
-mAX_DPH_SCALAR_ARGS :: Int
-mAX_DPH_SCALAR_ARGS = 8
-
--- Types from 'GHC.Prim' supported by DPH
---
-aLL_DPH_PRIM_TYCONS :: [Name]
-aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon]
-
-
--- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the
--- vectoriser.
---
-data Builtins
-        = Builtins
-        { parrayTyCon          :: TyCon                     -- ^ PArray
-        , pdataTyCon           :: TyCon                     -- ^ PData
-        , pdatasTyCon          :: TyCon                     -- ^ PDatas
-        , prClass              :: Class                     -- ^ PR
-        , prTyCon              :: TyCon                     -- ^ PR
-        , preprTyCon           :: TyCon                     -- ^ PRepr
-        , paClass              :: Class                     -- ^ PA
-        , paTyCon              :: TyCon                     -- ^ PA
-        , paDataCon            :: DataCon                   -- ^ PA
-        , paPRSel              :: Var                       -- ^ PA
-        , replicatePDVar       :: Var                       -- ^ replicatePD
-        , replicatePD_PrimVars :: NameEnv Var               -- ^ replicatePD_Int# etc.
-        , emptyPDVar           :: Var                       -- ^ emptyPD
-        , emptyPD_PrimVars     :: NameEnv Var               -- ^ emptyPD_Int# etc.
-        , packByTagPDVar       :: Var                       -- ^ packByTagPD
-        , packByTagPD_PrimVars :: NameEnv Var               -- ^ packByTagPD_Int# etc.
-        , combinePDVars        :: Array Int Var             -- ^ combinePD
-        , combinePD_PrimVarss  :: Array Int (NameEnv Var)   -- ^ combine2PD_Int# etc.
-        , scalarClass          :: Class                     -- ^ Scalar
-        , scalarZips           :: Array Int Var             -- ^ map, zipWith, zipWith3
-        , voidTyCon            :: TyCon                     -- ^ Void
-        , voidVar              :: Var                       -- ^ void
-        , fromVoidVar          :: Var                       -- ^ fromVoid
-        , sumTyCons            :: Array Int TyCon           -- ^ Sum2 .. Sum3
-        , wrapTyCon            :: TyCon                     -- ^ Wrap
-        , pvoidVar             :: Var                       -- ^ pvoid
-        , pvoidsVar            :: Var                       -- ^ pvoids
-        , closureTyCon         :: TyCon                     -- ^ :->
-        , closureVar           :: Var                       -- ^ closure
-        , liftedClosureVar     :: Var                       -- ^ liftedClosure
-        , applyVar             :: Var                       -- ^ $:
-        , liftedApplyVar       :: Var                       -- ^ liftedApply
-        , closureCtrFuns       :: Array Int Var             -- ^ closure1 .. closure3
-        , selTys               :: Array Int Type            -- ^ Sel2
-        , selsTys              :: Array Int Type            -- ^ Sels2
-        , selsLengths          :: Array Int CoreExpr        -- ^ lengthSels2
-        , selReplicates        :: Array Int CoreExpr        -- ^ replicate2
-        , selTagss             :: Array Int CoreExpr        -- ^ tagsSel2
-        , selElementss         :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
-        , liftingContext       :: Var                       -- ^ lc
-        }
-
-
--- Projections ----------------------------------------------------------------
--- We use these wrappers instead of indexing the `Builtin` structure directly
--- because they give nicer panic messages if the indexed thing cannot be found.
-
-selTy :: Int -> Builtins -> Type
-selTy           = indexBuiltin "selTy" selTys
-
-selsTy :: Int -> Builtins -> Type
-selsTy          = indexBuiltin "selsTy" selsTys
-
-selsLength :: Int -> Builtins -> CoreExpr
-selsLength      = indexBuiltin "selLength" selsLengths
-
-selReplicate :: Int -> Builtins -> CoreExpr
-selReplicate    = indexBuiltin "selReplicate" selReplicates
-
-selTags :: Int -> Builtins -> CoreExpr
-selTags         = indexBuiltin "selTags" selTagss
-
-selElements :: Int -> Int -> Builtins -> CoreExpr
-selElements i j = indexBuiltin "selElements" selElementss (i, j)
-
-sumTyCon :: Int -> Builtins -> TyCon
-sumTyCon        = indexBuiltin "sumTyCon" sumTyCons
-
-prodTyCon :: Int -> Builtins -> TyCon
-prodTyCon n _
-  | n >= 2 && n <= mAX_DPH_PROD
-  = tupleTyCon Boxed n
-  | otherwise
-  = pprPanic "prodTyCon" (ppr n)
-
-prodDataCon :: Int -> Builtins -> DataCon
-prodDataCon n bi
- = case tyConDataCons (prodTyCon n bi) of
-    [con] -> con
-    _ -> pprPanic "prodDataCon" (ppr n)
-
-replicatePD_PrimVar :: TyCon -> Builtins -> Var
-replicatePD_PrimVar tc bi
-  = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc)
-
-emptyPD_PrimVar :: TyCon -> Builtins -> Var
-emptyPD_PrimVar tc bi
-  = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc)
-
-packByTagPD_PrimVar :: TyCon -> Builtins -> Var
-packByTagPD_PrimVar tc bi
-  = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc)
-
-combinePDVar :: Int -> Builtins -> Var
-combinePDVar = indexBuiltin "combinePDVar" combinePDVars
-
-combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var
-combinePD_PrimVar i tc bi
-  = lookupEnvBuiltin "combinePD_PrimVar"
-      (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc)
-
-scalarZip :: Int -> Builtins -> Var
-scalarZip = indexBuiltin "scalarZip" scalarZips
-
-closureCtrFun :: Int -> Builtins -> Var
-closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
-
--- | Get an element from one of the arrays of `Builtins`.
---   Panic if the indexed thing is not in the array.
-indexBuiltin :: (Ix i, Outputable i)
-             => String                   -- ^ Name of the selector we've used, for panic messages.
-             -> (Builtins -> Array i a)  -- ^ Field selector for the `Builtins`.
-             -> i                        -- ^ Index into the array.
-             -> Builtins
-             -> a
-indexBuiltin fn f i bi
-  | inRange (bounds xs) i = xs ! i
-  | otherwise
-  = pprSorry "Vectorise.Builtins.indexBuiltin"
-    (vcat [ text ""
-    , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <>
-      text "' is not yet implemented."
-    , text "This function does not appear in your source program, but it is needed"
-    , text "to compile your code in the backend. This is a known, current limitation"
-    , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org"
-    , text "and ask what you can do to help (it might involve some GHC hacking)."])
-  where xs = f bi
-
-
--- | Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array.
-lookupEnvBuiltin :: String                    -- Function name for error messages
-                 -> NameEnv a                 -- Name environment
-                 -> Name                      -- Index into the name environment
-                 -> a
-lookupEnvBuiltin fn env n
-  | Just r <- lookupNameEnv env n = r
-  | otherwise
-  = pprSorry "Vectorise.Builtins.lookupEnvBuiltin"
-    (vcat [ text ""
-    , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <>
-      text "' is not yet implemented."
-    , text "This function does not appear in your source program, but it is needed"
-    , text "to compile your code in the backend. This is a known, current limitation"
-    , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org"
-    , text "and ask what you can do to help (it might involve some GHC hacking)."])
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
deleted file mode 100644
index 73cedc4c53..0000000000
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ /dev/null
@@ -1,232 +0,0 @@
--- Set up the data structures provided by 'Vectorise.Builtins'.
-
-module Vectorise.Builtins.Initialise (
-  -- * Initialisation
-  initBuiltins, initBuiltinVars
-) where
-
-import Vectorise.Builtins.Base
-
-import BasicTypes
-import TysPrim
-import DsMonad
-import TysWiredIn
-import DataCon
-import TyCon
-import Class
-import CoreSyn
-import Type
-import NameEnv
-import Name
-import Id
-import FastString
-import Outputable
-
-import Control.Monad
-import Data.Array
-
-
--- |Create the initial map of builtin types and functions.
---
-initBuiltins :: DsM Builtins
-initBuiltins
- = do {   -- 'PArray: representation type for parallel arrays
-      ; parrayTyCon <- externalTyCon (fsLit "PArray")
-
-          -- 'PData': type family mapping array element types to array representation types
-          -- Not all backends use `PDatas`.
-      ; pdataTyCon  <- externalTyCon (fsLit "PData")
-      ; pdatasTyCon <- externalTyCon (fsLit "PDatas")
-
-          -- 'PR': class of basic array operators operating on 'PData' types
-      ; prClass     <- externalClass (fsLit "PR")
-      ; let prTyCon     = classTyCon prClass
-
-          -- 'PRepr': type family mapping element types to representation types
-      ; preprTyCon  <- externalTyCon (fsLit "PRepr")
-
-          -- 'PA': class of basic operations on arrays (parametrised by the element type)
-      ; paClass     <- externalClass (fsLit "PA")
-      ; let paTyCon     = classTyCon paClass
-            [paDataCon] = tyConDataCons paTyCon
-            paPRSel     = classSCSelId paClass 0
-
-          -- Functions on array representations
-      ; replicatePDVar <- externalVar (fsLit "replicatePD")
-      ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS)
-      ; emptyPDVar     <- externalVar (fsLit "emptyPD")
-      ; empty_vars     <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS)
-      ; packByTagPDVar <- externalVar (fsLit "packByTagPD")
-      ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS)
-      ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]]
-      ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]]
-      ; combines       <- mapM externalVar (map mkFastString combineNamesD)
-      ; combines_vars  <- mapM (mapM externalVar) $
-                            map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA
-      ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars)
-            emptyPD_PrimVars     = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars)
-            packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars)
-            combinePDVars        = listArray (2, mAX_DPH_COMBINE) combines
-            combinePD_PrimVarss  = listArray (2, mAX_DPH_COMBINE)
-                                     [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars)
-                                     | vars <- combines_vars]
-
-          -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations
-      ; scalarClass <- externalClass (fsLit "Scalar")
-
-          -- N-ary maps ('zipWith' family)
-      ; scalar_map       <- externalVar (fsLit "scalar_map")
-      ; scalar_zip2      <- externalVar (fsLit "scalar_zipWith")
-      ; scalar_zips      <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
-      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS)
-                                     (scalar_map : scalar_zip2 : scalar_zips)
-
-          -- Types and functions for generic type representations
-      ; voidTyCon        <- externalTyCon (fsLit "Void")
-      ; voidVar          <- externalVar   (fsLit "void")
-      ; fromVoidVar      <- externalVar   (fsLit "fromVoid")
-      ; sum_tcs          <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM)
-      ; let sumTyCons    = listArray (2, mAX_DPH_SUM) sum_tcs
-      ; wrapTyCon        <- externalTyCon (fsLit "Wrap")
-      ; pvoidVar         <- externalVar   (fsLit "pvoid")
-      ; pvoidsVar        <- externalVar   (fsLit "pvoids#")
-
-          -- Types and functions for closure conversion
-      ; closureTyCon     <- externalTyCon (fsLit ":->")
-      ; closureVar       <- externalVar   (fsLit "closure")
-      ; liftedClosureVar <- externalVar   (fsLit "liftedClosure")
-      ; applyVar         <- externalVar   (fsLit "$:")
-      ; liftedApplyVar   <- externalVar   (fsLit "liftedApply")
-      ; closures         <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
-      ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures
-
-          -- Types and functions for selectors
-      ; sel_tys          <- mapM externalType (numbered "Sel"  2 mAX_DPH_SUM)
-      ; sels_tys         <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM)
-      ; sels_length      <- mapM externalFun  (numbered_hash "lengthSels"   2 mAX_DPH_SUM)
-      ; sel_replicates   <- mapM externalFun  (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
-      ; sel_tags         <- mapM externalFun  (numbered "tagsSel" 2 mAX_DPH_SUM)
-      ; sel_elements     <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
-      ; let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
-            selsTys       = listArray (2, mAX_DPH_SUM) sels_tys
-            selsLengths   = listArray (2, mAX_DPH_SUM) sels_length
-            selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
-            selTagss      = listArray (2, mAX_DPH_SUM) sel_tags
-            selElementss  = array     ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements
-
-          -- Distinct local variable
-      ; liftingContext  <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique
-
-      ; return $ Builtins
-               { parrayTyCon          = parrayTyCon
-               , pdataTyCon           = pdataTyCon
-               , pdatasTyCon          = pdatasTyCon
-               , preprTyCon           = preprTyCon
-               , prClass              = prClass
-               , prTyCon              = prTyCon
-               , paClass              = paClass
-               , paTyCon              = paTyCon
-               , paDataCon            = paDataCon
-               , paPRSel              = paPRSel
-               , replicatePDVar       = replicatePDVar
-               , replicatePD_PrimVars = replicatePD_PrimVars
-               , emptyPDVar           = emptyPDVar
-               , emptyPD_PrimVars     = emptyPD_PrimVars
-               , packByTagPDVar       = packByTagPDVar
-               , packByTagPD_PrimVars = packByTagPD_PrimVars
-               , combinePDVars        = combinePDVars
-               , combinePD_PrimVarss  = combinePD_PrimVarss
-               , scalarClass          = scalarClass
-               , scalarZips           = scalarZips
-               , voidTyCon            = voidTyCon
-               , voidVar              = voidVar
-               , fromVoidVar          = fromVoidVar
-               , sumTyCons            = sumTyCons
-               , wrapTyCon            = wrapTyCon
-               , pvoidVar             = pvoidVar
-               , pvoidsVar            = pvoidsVar
-               , closureTyCon         = closureTyCon
-               , closureVar           = closureVar
-               , liftedClosureVar     = liftedClosureVar
-               , applyVar             = applyVar
-               , liftedApplyVar       = liftedApplyVar
-               , closureCtrFuns       = closureCtrFuns
-               , selTys               = selTys
-               , selsTys              = selsTys
-               , selsLengths          = selsLengths
-               , selReplicates        = selReplicates
-               , selTagss             = selTagss
-               , selElementss         = selElementss
-               , liftingContext       = liftingContext
-               }
-      }
-  where
-    suffixed :: String -> [Name] -> [FastString]
-    suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns]
-
-    -- Make a list of numbered strings in some range, eg foo3, foo4, foo5
-    numbered :: String -> Int -> Int -> [FastString]
-    numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]
-
-    numbered_hash :: String -> Int -> Int -> [FastString]
-    numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]
-
-    mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
-    mk_elements (i,j)
-      = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
-           ; return ((i, j), Var v)
-           }
-
--- |Get the mapping of names in the Prelude to names in the DPH library.
---
-initBuiltinVars :: Builtins -> DsM [(Var, Var)]
--- FIXME: must be replaced by VECTORISE pragmas!!!
-initBuiltinVars (Builtins { })
-  = do
-      cvars <- mapM externalVar cfs
-      return $ zip (map dataConWorkId cons) cvars
-  where
-    (cons, cfs) = unzip preludeDataCons
-
-    preludeDataCons :: [(DataCon, FastString)]
-    preludeDataCons
-      = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]]
-      where
-        mk_tup n name = (tupleDataCon Boxed n, name)
-
-
--- Auxiliary look up functions -----------------------------------------------
-
--- |Lookup a variable given its name and the module that contains it.
-externalVar :: FastString -> DsM Var
-externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
-
-
--- |Like `externalVar` but wrap the `Var` in a `CoreExpr`.
-externalFun :: FastString -> DsM CoreExpr
-externalFun fs = Var <$> externalVar fs
-
-
--- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
---  Panic if there isn't one.
-externalTyCon :: FastString -> DsM TyCon
-externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon
-
-
--- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name.
-externalType :: FastString -> DsM Type
-externalType fs
- = do  tycon <- externalTyCon fs
-       return $ mkTyConApp tycon []
-
-
--- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name.
-externalClass :: FastString -> DsM Class
-externalClass fs
-  = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
-       ; case tyConClass_maybe tycon of
-           Nothing  -> pprPanic "Vectorise.Builtins.Initialise" $
-                         text "Data.Array.Parallel.Prim." <>
-                         ftext fs <+> text "is not a type class"
-           Just cls -> return cls
-       }
diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs
deleted file mode 100644
index b3b70986e5..0000000000
--- a/compiler/vectorise/Vectorise/Convert.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-module Vectorise.Convert
-  ( fromVect
-  )
-where
-
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Type.Type
-
-import CoreSyn
-import TyCon
-import Type
-import TyCoRep
-import NameSet
-import FastString
-import Outputable
-
-import Control.Applicative
-import Prelude -- avoid redundant import warning due to AMP
-
--- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its
--- value.
---
--- For functions, we eta expand the function and convert the arguments and result:
-
--- For example
--- @
---    \(x :: Double) ->
---    \(y :: Double) ->
---    ($v_foo $: x) $: y
--- @
---
--- We use the type of the original binding to work out how many outer lambdas to add.
---
-fromVect :: Type        -- ^ The type of the original binding.
-         -> CoreExpr    -- ^ Expression giving the closure to use, eg @$v_foo@.
-         -> VM CoreExpr
-
--- Convert the type to the core view if it isn't already.
---
-fromVect ty expr
-  | Just ty' <- coreView ty
-  = fromVect ty' expr
-
--- For each function constructor in the original type we add an outer
--- lambda to bind the parameter variable, and an inner application of it.
-fromVect (FunTy arg_ty res_ty) expr
-  = do
-      arg     <- newLocalVar (fsLit "x") arg_ty
-      varg    <- toVect arg_ty (Var arg)
-      varg_ty <- vectType arg_ty
-      vres_ty <- vectType res_ty
-      apply   <- builtin applyVar
-      body    <- fromVect res_ty
-               $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg]
-      return $ Lam arg body
-
--- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e.,
--- is identical to the non-vectorised version).
---
-fromVect ty expr
-  = identityConv ty >> return expr
-
--- Convert an expression such that it evaluates to the vectorised equivalent of the value of the
--- original expression.
---
--- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the
---          original one.
---
-toVect :: Type -> CoreExpr -> VM CoreExpr
-toVect ty expr = identityConv ty >> return expr
-
--- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor
--- are not altered by vectorisation as they contain no parallel arrays.
---
-identityConv :: Type -> VM ()
-identityConv ty
-  | Just ty' <- coreView ty
-  = identityConv ty'
-identityConv (TyConApp tycon tys)
-  = do { mapM_ identityConv tys
-       ; identityConvTyCon tycon
-       }
-identityConv (LitTy {})      = noV $ text "identityConv: not sure about literal types under vectorisation"
-identityConv (TyVarTy {})    = noV $ text "identityConv: type variable changes under vectorisation"
-identityConv (AppTy {})      = noV $ text "identityConv: type appl. changes under vectorisation"
-identityConv (FunTy {})      = noV $ text "identityConv: function type changes under vectorisation"
-identityConv (ForAllTy {})   = noV $ text "identityConv: quantified type changes under vectorisation"
-identityConv (CastTy {})     = noV $ text "identityConv: not sure about casted types under vectorisation"
-identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation"
-
--- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any
--- parallel arrays.
---
-identityConvTyCon :: TyCon -> VM ()
-identityConvTyCon tc
-  = do
-    { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons
-    ; parray     <- builtin parrayTyCon
-    ; if isParallel && not (tc == parray)
-      then noV idErr
-      else return ()
-    }
-  where
-    idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
deleted file mode 100644
index 8f1a0a0662..0000000000
--- a/compiler/vectorise/Vectorise/Env.hs
+++ /dev/null
@@ -1,238 +0,0 @@
-module Vectorise.Env (
-  Scope(..),
-
-  -- * Local Environments
-  LocalEnv(..),
-  emptyLocalEnv,
-
-  -- * Global Environments
-  GlobalEnv(..),
-  initGlobalEnv,
-  extendImportedVarsEnv,
-  extendFamEnv,
-  setPAFunsEnv,
-  setPRFunsEnv,
-  modVectInfo
-) where
-
-import HscTypes
-import InstEnv
-import FamInstEnv
-import CoreSyn
-import Type
-import Class
-import TyCon
-import DataCon
-import VarEnv
-import VarSet
-import Var
-import NameSet
-import Name
-import NameEnv
-import FastString
-import UniqDFM
-import UniqSet
-
-
-import Data.Maybe
-
-
--- |Indicates what scope something (a variable) is in.
---
-data Scope a b
-        = Global a
-        | Local  b
-
-
--- LocalEnv -------------------------------------------------------------------
-
--- |The local environment.
---
-data LocalEnv
-        = LocalEnv
-        { local_vars      :: VarEnv (Var, Var)
-          -- ^Mapping from local variables to their vectorised and lifted versions.
-
-        , local_tyvars     :: [TyVar]
-          -- ^In-scope type variables.
-
-        , local_tyvar_pa   :: VarEnv CoreExpr
-          -- ^Mapping from tyvars to their PA dictionaries.
-
-        , local_bind_name  :: FastString
-          -- ^Local binding name. This is only used to generate better names for hoisted
-          -- expressions.
-        }
-
--- |Create an empty local environment.
---
-emptyLocalEnv :: LocalEnv
-emptyLocalEnv = LocalEnv
-                { local_vars      = emptyVarEnv
-                , local_tyvars    = []
-                , local_tyvar_pa  = emptyVarEnv
-                , local_bind_name = fsLit "fn"
-                }
-
-
--- GlobalEnv ------------------------------------------------------------------
-
--- |The global environment: entities that exist at top-level.
---
-data GlobalEnv
-        = GlobalEnv
-        { global_vect_avoid           :: Bool
-          -- ^'True' implies to avoid vectorisation as far as possible.
-
-        , global_vars                 :: VarEnv Var
-          -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation
-          -- map/.
-
-        , global_parallel_vars        :: DVarSet
-          -- ^The domain of 'global_vars'.
-          --
-          -- This information is not redundant as it is impossible to extract the domain from a
-          -- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that
-          -- do not involve parallelism — e.g., the workers of vectorised, but scalar data types.
-          -- In addition, workers of parallel data types that we could not vectorise also need to
-          -- be tracked.
-
-        , global_vect_decls           :: VarEnv (Maybe (Type, CoreExpr))
-          -- ^Mapping from global variables that have a vectorisation declaration to the right-hand
-          -- side of that declaration and its type and mapping variables that have NOVECTORISE
-          -- declarations to 'Nothing'.
-
-        , global_tycons               :: NameEnv TyCon
-          -- ^Mapping from TyCons to their vectorised versions. The vectorised version will be
-          -- identical to the original version if it is not changed by vectorisation. In any case,
-          -- if a tycon appears in the domain of this mapping, it was successfully vectorised.
-
-        , global_parallel_tycons      :: NameSet
-          -- ^Type constructors whose definition directly or indirectly includes a parallel type,
-          -- such as '[::]'.
-          --
-          -- NB: This information is not redundant as some types have got a mapping in
-          --     'global_tycons' (to a type other than themselves) and are still not parallel. An
-          --     example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons'
-          --     (because they couldn't be vectorised), but still contain parallel types.
-
-        , global_datacons             :: NameEnv DataCon
-          -- ^Mapping from DataCons to their vectorised versions.
-
-        , global_pa_funs              :: NameEnv Var
-          -- ^Mapping from TyCons to their PA dfuns.
-
-        , global_pr_funs              :: NameEnv Var
-          -- ^Mapping from TyCons to their PR dfuns.
-
-        , global_inst_env             :: InstEnvs
-          -- ^External package inst-env & home-package inst-env for class instances.
-
-        , global_fam_inst_env         :: FamInstEnvs
-          -- ^External package inst-env & home-package inst-env for family instances.
-
-        , global_bindings             :: [(Var, CoreExpr)]
-          -- ^Hoisted bindings — temporary storage for toplevel bindings during code gen.
-        }
-
--- |Create an initial global environment.
---
--- We add scalar variables and type constructors identified by vectorisation pragmas already here
--- to the global table, so that we can query scalarness during vectorisation, and especially, when
--- vectorising the scalar entities' definitions themselves.
---
-initGlobalEnv :: Bool
-              -> VectInfo
-              -> [CoreVect]
-              -> InstEnvs
-              -> FamInstEnvs
-              -> GlobalEnv
-initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs
-  = GlobalEnv
-  { global_vect_avoid           = vectAvoid
-  , global_vars                 = mapVarEnv snd $ udfmToUfm $ vectInfoVar info
-  , global_vect_decls           = mkVarEnv vects
-  , global_parallel_vars        = vectInfoParallelVars info
-  , global_parallel_tycons      = vectInfoParallelTyCons info
-  , global_tycons               = mapNameEnv snd $ vectInfoTyCon info
-  , global_datacons             = mapNameEnv snd $ vectInfoDataCon info
-  , global_pa_funs              = emptyNameEnv
-  , global_pr_funs              = emptyNameEnv
-  , global_inst_env             = instEnvs
-  , global_fam_inst_env         = famInstEnvs
-  , global_bindings             = []
-  }
-  where
-    vects         = [(var, Just (ty, exp)) | Vect   var   exp@(Var rhs_var) <- vectDecls
-                                           , let ty = varType rhs_var] ++
-                                        -- FIXME: we currently only allow RHSes consisting of a
-                                        --   single variable to be able to obtain the type without
-                                        --   inference — see also 'TcBinds.tcVect'
-                    [(var, Nothing)        | NoVect var                     <- vectDecls]
-
-
--- Operators on Global Environments -------------------------------------------
-
--- |Extend the list of global variables in an environment.
---
-extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
-extendImportedVarsEnv ps genv
-  = genv { global_vars = extendVarEnvList (global_vars genv) ps }
-
--- |Extend the list of type family instances.
---
-extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv
-extendFamEnv new genv
-  = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
-  where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
-
--- |Set the list of PA functions in an environment.
---
-setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps }
-
--- |Set the list of PR functions in an environment.
---
-setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
-
--- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).
--- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'.  The outgoing one contains only the
--- declarations for the currently compiled module; this includes variables, type constructors, and
--- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported
--- module.
---
--- The variables explicitly include class selectors and dfuns.
---
-modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
-modVectInfo env mg_ids mg_tyCons vectDecls info
-  = info
-    { vectInfoVar            = mk_denv ids     (global_vars     env)
-    , vectInfoTyCon          = mk_env tyCons   (global_tycons   env)
-    , vectInfoDataCon        = mk_env dataCons (global_datacons env)
-    , vectInfoParallelVars   = (global_parallel_vars   env `minusDVarSet`  vectInfoParallelVars   info)
-                               `udfmIntersectUFM` (getUniqSet $ mkVarSet ids)
-    , vectInfoParallelTyCons =  global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info
-    }
-  where
-    vectIds         = [id    | Vect     id    _   <- vectDecls] ++
-                      [id    | VectInst id        <- vectDecls]
-    vectTypeTyCons  = [tycon | VectType _ tycon _ <- vectDecls] ++
-                      [tycon | VectClass tycon    <- vectDecls]
-    vectDataCons    = concatMap tyConDataCons vectTypeTyCons
-    ids             = mg_ids ++ vectIds ++ dataConIds ++ selIds
-    tyCons          = mg_tyCons ++ vectTypeTyCons
-    dataCons        = concatMap tyConDataCons mg_tyCons ++ vectDataCons
-    dataConIds      = map dataConWorkId dataCons
-    selIds          = concat [ classAllSelIds cls
-                             | tycon <- tyCons
-                             , cls <- maybeToList . tyConClass_maybe $ tycon]
-
-    -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
-    mk_env decls inspectedEnv = mkNameEnv $ mk_assoc_env decls inspectedEnv
-    mk_denv decls inspectedEnv = listToUDFM $ mk_assoc_env decls inspectedEnv
-    mk_assoc_env decls inspectedEnv
-      = [(name, (decl, to))
-        | decl     <- decls
-        , let name = getName decl
-        , Just to  <- [lookupNameEnv inspectedEnv name]]
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
deleted file mode 100644
index f4c1361d74..0000000000
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ /dev/null
@@ -1,1257 +0,0 @@
-{-# LANGUAGE CPP, TupleSections #-}
-
--- |Vectorisation of expressions.
-
-module Vectorise.Exp
-  (   -- * Vectorise right-hand sides of toplevel bindings
-    vectTopExpr
-  , vectTopExprs
-  , vectScalarFun
-  , vectScalarDFun
-  )
-where
-
-#include "HsVersions.h"
-
-import Vectorise.Type.Type
-import Vectorise.Var
-import Vectorise.Convert
-import Vectorise.Vect
-import Vectorise.Env
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Utils
-
-import CoreUtils
-import MkCore
-import CoreSyn
-import CoreFVs
-import Class
-import DataCon
-import TyCon
-import TcType
-import Type
-import TyCoRep
-import Var
-import VarEnv
-import VarSet
-import NameSet
-import Id
-import BasicTypes( isStrongLoopBreaker )
-import Literal
-import TysPrim
-import Outputable
-import FastString
-import DynFlags
-import Util
-
-import Control.Monad
-import Data.Maybe
-import Data.List
-
-
--- Main entry point to vectorise expressions -----------------------------------
-
--- |Vectorise a polymorphic expression that forms a *non-recursive* binding.
---
--- Return 'Nothing' if the expression is scalar; otherwise, the first component of the result
--- (which is of type 'Bool') indicates whether the expression is parallel (i.e., whether it is
--- tagged as 'VIParr').
---
--- We have got the non-recursive case as a special case as it doesn't require to compute
--- vectorisation information twice.
---
-vectTopExpr :: Var -> CoreExpr -> VM (Maybe (Bool, Inline, CoreExpr))
-vectTopExpr var expr
-  = do
-    { exprVI <- encapsulateScalars <=< vectAvoidInfo emptyVarSet . freeVars $ expr
-    ; if isVIEncaps exprVI
-      then
-        return Nothing
-      else do
-      { vExpr <- closedV $
-                   inBind var $
-                     vectAnnPolyExpr False exprVI
-      ; inline <- computeInline exprVI
-      ; return $ Just (isVIParr exprVI, inline, vectorised vExpr)
-      }
-    }
-
--- Compute the inlining hint for the right-hand side of a top-level binding.
---
-computeInline :: CoreExprWithVectInfo -> VM Inline
-computeInline ((_, VIDict), _)     = return $ DontInline
-computeInline (_, AnnTick _ expr)  = computeInline expr
-computeInline expr@(_, AnnLam _ _) = Inline <$> polyArity tvs
-  where
-    (tvs, _) = collectAnnTypeBinders expr
-computeInline _expr                = return $ DontInline
-
--- |Vectorise a recursive group of top-level polymorphic expressions.
---
--- Return 'Nothing' if the expression group is scalar; otherwise, the first component of the result
--- (which is of type 'Bool') indicates whether the expressions are parallel (i.e., whether they are
--- tagged as 'VIParr').
---
-vectTopExprs :: [(Var, CoreExpr)] -> VM (Maybe (Bool, [(Inline, CoreExpr)]))
-vectTopExprs binds
-  = do
-    { exprVIs <- mapM (vectAvoidAndEncapsulate emptyVarSet) exprs
-    ; if all isVIEncaps exprVIs
-        -- if all bindings are scalar => don't vectorise this group of bindings
-      then return Nothing
-      else do
-      {   -- non-scalar bindings need to be vectorised
-      ; let areVIParr = any isVIParr exprVIs
-      ; revised_exprVIs <- if not areVIParr
-                             -- if no binding is parallel => 'exprVIs' is ready for vectorisation
-                           then return exprVIs
-                             -- if any binding is parallel => recompute the vectorisation info
-                           else mapM (vectAvoidAndEncapsulate (mkVarSet vars)) exprs
-
-      ; vExprs <- zipWithM vect vars revised_exprVIs
-      ; return $ Just (areVIParr, vExprs)
-      }
-    }
-  where
-    (vars, exprs) = unzip binds
-
-    vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars
-
-    vect var exprVI
-      = do
-        { vExpr  <- closedV $
-                      inBind var $
-                        vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo var) exprVI
-        ; inline <- computeInline exprVI
-        ; return (inline, vectorised vExpr)
-        }
-
--- |Vectorise a polymorphic expression annotated with vectorisation information.
---
--- The special case of dictionary functions is currently handled separately. (Would be neater to
--- integrate them, though!)
---
-vectAnnPolyExpr :: Bool -> CoreExprWithVectInfo -> VM VExpr
-vectAnnPolyExpr loop_breaker (_, AnnTick tickish expr)
-    -- traverse through ticks
-  = vTick tickish <$> vectAnnPolyExpr loop_breaker expr
-vectAnnPolyExpr loop_breaker expr
-  | isVIDict expr
-    -- special case the right-hand side of dictionary functions
-  = (, undefined) <$> vectDictExpr (deAnnotate expr)
-  | otherwise
-    -- collect and vectorise type abstractions; then, descent into the body
-  = polyAbstract tvs $ \args ->
-      mapVect (mkLams $ tvs ++ args) <$> vectFnExpr False loop_breaker mono
-  where
-    (tvs, mono) = collectAnnTypeBinders expr
-
--- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a
--- lambda abstraction over all its free variables followed by the corresponding application to those
--- variables.  We can, then, avoid the vectorisation of the ensapsulated subexpressions.
---
--- Preconditions:
---
--- * All free variables and the result type must be /simple/ types.
--- * The expression is sufficiently complex (to warrant special treatment).  For now, that is
---   every expression that is not constant and contains at least one operation.
---
---
--- The user has an option to choose between aggressive and minimal vectorisation avoidance. With
--- minimal vectorisation avoidance, we only encapsulate individual scalar operations. With
--- aggressive vectorisation avoidance, we encapsulate subexpression that are as big as possible.
---
-encapsulateScalars :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo
-encapsulateScalars ce@(_, AnnType _ty)
-  = return ce
-encapsulateScalars ce@((_, VISimple), AnnVar _v)
-      -- NB: diverts from the paper: encapsulate scalar variables (including functions)
-  = liftSimpleAndCase ce
-encapsulateScalars ce@(_, AnnVar _v)
-  = return ce
-encapsulateScalars ce@(_, AnnLit _)
-  = return ce
-encapsulateScalars ((fvs, vi), AnnTick tck expr)
-  = do
-    { encExpr <- encapsulateScalars expr
-    ; return ((fvs, vi), AnnTick tck encExpr)
-    }
-encapsulateScalars ce@((fvs, vi), AnnLam bndr expr)
-  = do
-    { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs
-        -- NB: diverts from the paper: we need to check the scalarness of bound variables as well,
-        --     as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs'
-        --     by encapsulation.
-    ; bndrsS    <- allScalarVarType bndrs
-    ; case (vi, vectAvoid && varsS && bndrsS) of
-        (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do
-                            { encExpr <- encapsulateScalars expr
-                            ; return ((fvs, vi), AnnLam bndr encExpr)
-                            }
-    }
-  where
-    (bndrs, _) = collectAnnBndrs ce
-encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2)
-  = do
-    { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs
-    ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of
-        (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do
-                            { encCe1 <- encapsulateScalars ce1
-                            ; encCe2 <- encapsulateScalars ce2
-                            ; return ((fvs, vi), AnnApp encCe1 encCe2)
-                            }
-    }
-  where
-    isSimpleApplication :: CoreExprWithVectInfo -> Bool
-    isSimpleApplication (_, AnnTick _ ce)                 = isSimpleApplication ce
-    isSimpleApplication (_, AnnCast ce _)                 = isSimpleApplication ce
-    isSimpleApplication ce                  | isSimple ce = True
-    isSimpleApplication (_, AnnApp ce1 ce2)               = isSimple ce1 && isSimpleApplication ce2
-    isSimpleApplication _                                 = False
-    --
-    isSimple :: CoreExprWithVectInfo -> Bool
-    isSimple (_, AnnType {})   = True
-    isSimple (_, AnnVar  {})   = True
-    isSimple (_, AnnLit  {})   = True
-    isSimple (_, AnnTick _ ce) = isSimple ce
-    isSimple (_, AnnCast ce _) = isSimple ce
-    isSimple _                 = False
-encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts)
-  = do
-    { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs
-    ; case (vi, vectAvoid && varsS) of
-        (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do
-                            { encScrut <- encapsulateScalars scrut
-                            ; encAlts  <- mapM encAlt alts
-                            ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts)
-                            }
-    }
-  where
-    encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr
-encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2)
-  = do
-    { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs
-    ; case (vi, vectAvoid && varsS) of
-        (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do
-                            { encExpr1 <- encapsulateScalars expr1
-                            ; encExpr2 <- encapsulateScalars expr2
-                            ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2)
-                            }
-    }
-encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr)
-  = do
-    { vectAvoid <- isVectAvoidanceAggressive
-    ; varsS     <- allScalarVarTypeSet fvs
-    ; case (vi, vectAvoid && varsS) of
-        (VISimple, True) -> liftSimpleAndCase ce
-        _                -> do
-                            { encBinds <- mapM encBind binds
-                            ; encExpr  <- encapsulateScalars expr
-                            ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr)
-                            }
-    }
- where
-   encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr
-encapsulateScalars ((fvs, vi), AnnCast expr coercion)
-  = do
-    { encExpr <- encapsulateScalars expr
-    ; return ((fvs, vi), AnnCast encExpr coercion)
-    }
-encapsulateScalars _
-  = panic "Vectorise.Exp.encapsulateScalars: unknown constructor"
-
--- Lambda-lift the given simple expression and apply it to the abstracted free variables.
---
--- If the expression is a case expression scrutinising anything, but a scalar type, then lift
--- each alternative individually.
---
-liftSimpleAndCase :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo
-liftSimpleAndCase aexpr@((fvs, _vi), AnnCase expr bndr t alts)
-  = do
-    { vi <- vectAvoidInfoTypeOf expr
-    ; if (vi == VISimple)
-      then
-        liftSimple aexpr  -- if the scrutinee is scalar, we need no special treatment
-      else do
-      { alts' <- mapM (\(ac, bndrs, aexpr) -> (ac, bndrs,) <$> liftSimpleAndCase aexpr) alts
-      ; return ((fvs, vi), AnnCase expr bndr t alts')
-      }
-    }
-liftSimpleAndCase aexpr = liftSimple aexpr
-
-liftSimple :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo
-liftSimple ((fvs, vi), AnnVar v)
-  | v `elemDVarSet` fvs               -- special case to avoid producing: (\v -> v) v
-  && not (isToplevel v)               --   NB: if 'v' not free or is toplevel, we must get the 'VIEncaps'
-  = return $ ((fvs, vi), AnnVar v)
-liftSimple aexpr@((fvs_orig, VISimple), expr)
-  = do
-    { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars
-
-    ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr)
-
-    ; return $ liftedExpr
-    }
-  where
-    vars = dVarSetElems fvs
-    fvs  = filterDVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel
-
-    mkAnnLams :: [Var] -> DVarSet -> AnnExpr' Var (DVarSet, VectAvoidInfo) -> CoreExprWithVectInfo
-    mkAnnLams []     fvs expr = ASSERT(isEmptyDVarSet fvs)
-                                ((emptyDVarSet, VIEncaps), expr)
-    mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delDVarSet` v) (AnnLam v ((fvs, VIEncaps), expr))
-
-    mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo
-    mkAnnApps aexpr []     = aexpr
-    mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs
-
-    mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo
-    mkAnnApp aexpr@((fvs, _vi), _expr) v
-      = ((fvs `extendDVarSet` v, VISimple), AnnApp aexpr ((unitDVarSet v, VISimple), AnnVar v))
-liftSimple aexpr
-  = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr)
-
-isToplevel :: Var -> Bool
-isToplevel v | isId v    = case realIdUnfolding v of
-                             NoUnfolding                     -> False
-                             BootUnfolding                   -> False
-                             OtherCon      {}                -> True
-                             DFunUnfolding {}                -> True
-                             CoreUnfolding {uf_is_top = top} -> top
-             | otherwise = False
-
--- |Vectorise an expression.
---
-vectExpr :: CoreExprWithVectInfo -> VM VExpr
-
-vectExpr aexpr
-    -- encapsulated expression of functional type => try to vectorise as a scalar subcomputation
-  | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr
-  = vectFnExpr True False aexpr
-    -- encapsulated constant => vectorise as a scalar constant
-  | isVIEncaps aexpr
-  = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >>
-    vectConst (deAnnotate aexpr)
-
-vectExpr (_, AnnVar v)
-  = vectVar v
-
-vectExpr (_, AnnLit lit)
-  = vectConst $ Lit lit
-
-vectExpr aexpr@(_, AnnLam _ _)
-  = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >>
-    vectFnExpr True False aexpr
-
-  -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
-  --   its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
-  --   happy.
--- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now?
-vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
-  | v == pAT_ERROR_ID
-  = do
-    { (vty, lty) <- vectAndLiftType ty
-    ; return (mkCoreApps (Var v) [Type (getRuntimeRep "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err'])
-    }
-  where
-    err' = deAnnotate err
-
-  -- type application (handle multiple consecutive type applications simultaneously to ensure the
-  -- PA dictionaries are put at the right places)
-vectExpr e@(_, AnnApp _ arg)
-  | isAnnTypeArg arg
-  = vectPolyApp e
-
-  -- Lifted literal
-vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit))
-  | Just _con <- isDataConId_maybe v
-  = do
-    { let vexpr = App (Var v) (Lit lit)
-    ; lexpr <- liftPD vexpr
-    ; return (vexpr, lexpr)
-    }
-
-  -- value application (dictionary or user value)
-vectExpr e@(_, AnnApp fn arg)
-  | isPredTy arg_ty   -- dictionary application (whose result is not a dictionary)
-  = vectPolyApp e
-  | otherwise         -- user value
-  = do
-    {   -- vectorise the types
-    ; varg_ty <- vectType arg_ty
-    ; vres_ty <- vectType res_ty
-
-        -- vectorise the function and argument expression
-    ; vfn  <- vectExpr fn
-    ; varg <- vectExpr arg
-
-        -- the vectorised function is a closure; apply it to the vectorised argument
-    ; mkClosureApp varg_ty vres_ty vfn varg
-    }
-  where
-    (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn
-
-vectExpr (_, AnnCase scrut bndr ty alts)
-  | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty
-  , isAlgTyCon tycon
-  = vectAlgCase tycon ty_args scrut bndr ty alts
-  | otherwise
-  = do
-    { dflags <- getDynFlags
-    ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $
-        ppr scrut_ty
-    }
-  where
-    scrut_ty = exprType (deAnnotate scrut)
-
-vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
-  = do
-    { traceVt "let binding (non-recursive)" Outputable.empty
-    ; vrhs <- localV $
-                inBind bndr $
-                  vectAnnPolyExpr False rhs
-    ; traceVt "let body (non-recursive)" Outputable.empty
-    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
-    ; return $ vLet (vNonRec vbndr vrhs) vbody
-    }
-
-vectExpr (_, AnnLet (AnnRec bs) body)
-  = do
-    { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do
-                                  { traceVt "let bindings (recursive)" Outputable.empty
-                                  ; vrhss <- zipWithM vect_rhs bndrs rhss
-                                  ; traceVt "let body (recursive)" Outputable.empty
-                                  ; vbody <- vectExpr body
-                                  ; return (vrhss, vbody)
-                                  }
-    ; return $ vLet (vRec vbndrs vrhss) vbody
-    }
-  where
-    (bndrs, rhss) = unzip bs
-
-    vect_rhs bndr rhs = localV $
-                          inBind bndr $
-                            vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) rhs
-
-vectExpr (_, AnnTick tickish expr)
-  = vTick tickish <$> vectExpr expr
-
-vectExpr (_, AnnType ty)
-  = vType <$> vectType ty
-
-vectExpr e
-  = do
-    { dflags <- getDynFlags
-    ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e)
-    }
-
--- |Vectorise an expression that *may* have an outer lambda abstraction. If the expression is marked
--- as encapsulated ('VIEncaps'), vectorise it as a scalar computation (using a generalised scalar
--- zip).
---
--- We do not handle type variables at this point, as they will already have been stripped off by
--- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only
--- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere.
---
-vectFnExpr :: Bool                  -- ^If we process the RHS of a binding, whether that binding
-                                    --  should be inlined
-           -> Bool                  -- ^Whether the binding is a loop breaker
-           -> CoreExprWithVectInfo  -- ^Expression to vectorise; must have an outer `AnnLam`
-           -> VM VExpr
-vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body)
-    -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type
-  | isId bndr
-    && isPredTy (idType bndr)
-  = do
-    { vBndr <- vectBndr bndr
-    ; vbody <- vectFnExpr inline loop_breaker body
-    ; return $ mapVect (mkLams [vectorised vBndr]) vbody
-    }
-    -- encapsulated non-predicate abstraction: vectorise as a scalar computation
-  | isId bndr && isVIEncaps aexpr
-  = vectScalarFun . deAnnotate $ aexpr
-    -- non-predicate abstraction: vectorise as a non-scalar computation
-  | isId bndr
-  = vectLam inline loop_breaker aexpr
-  | otherwise
-  = do
-    { dflags <- getDynFlags
-    ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $
-        ppr (deAnnotate aexpr)
-    }
-vectFnExpr _ _ aexpr
-    -- encapsulated function: vectorise as a scalar computation
-  | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr
-  = vectScalarFun . deAnnotate $ aexpr
-  | otherwise
-    -- not an abstraction: vectorise as a non-scalar vanilla expression
-    -- NB: we can get here due to the recursion in the first case above and from 'vectAnnPolyExpr'
-  = vectExpr aexpr
-
--- |Vectorise type and dictionary applications.
---
--- These are always headed by a variable (as we don't support higher-rank polymorphism), but may
--- involve two sets of type variables and dictionaries. Consider,
---
--- > class C a where
--- >   m :: D b => b -> a
---
--- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'.
---
-vectPolyApp :: CoreExprWithVectInfo -> VM VExpr
-vectPolyApp e0
-  = case e4 of
-      (_, AnnVar var)
-        -> do {   -- get the vectorised form of the variable
-              ; vVar <- lookupVar var
-              ; traceVt "vectPolyApp of" (ppr var)
-
-                  -- vectorise type and dictionary arguments
-              ; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter)
-              ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner)
-              ; vTysOuter   <- mapM vectType     tysOuter
-              ; vTysInner   <- mapM vectType     tysInner
-
-              ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter
-
-              ; case vVar of
-                  Local (vv, lv)
-                    -> do { MASSERT( null dictsInner )    -- local vars cannot be class selectors
-                          ; traceVt "  LOCAL" (text "")
-                          ; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv)
-                          }
-                  Global vv
-                    | isDictComp var                      -- dictionary computation
-                    -> do {   -- in a dictionary computation, the innermost, non-empty set of
-                              -- arguments are non-vectorised arguments, where no 'PA'dictionaries
-                              -- are needed for the type variables
-                          ; ve <- if null dictsInner
-                                  then
-                                    return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter
-                                  else
-                                    reconstructOuter
-                                      (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner)
-                          ; traceVt "  GLOBAL (dict):" (ppr ve)
-                          ; vectConst ve
-                          }
-                    | otherwise                           -- non-dictionary computation
-                    -> do { MASSERT( null dictsInner )
-                          ; ve <- reconstructOuter (Var vv)
-                          ; traceVt "  GLOBAL (non-dict):" (ppr ve)
-                          ; vectConst ve
-                          }
-              }
-      _ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0)
-  where
-    -- if there is only one set of variables or dictionaries, it will be the outer set
-    (e1, dictsOuter) = collectAnnDictArgs e0
-    (e2, tysOuter)   = collectAnnTypeArgs e1
-    (e3, dictsInner) = collectAnnDictArgs e2
-    (e4, tysInner)   = collectAnnTypeArgs e3
-    --
-    isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var
-
--- |Vectorise the body of a dfun.
---
--- Dictionary computations are special for the following reasons.  The application of dictionary
--- functions are always saturated, so there is no need to create closures.  Dictionary computations
--- don't depend on array values, so they are always scalar computations whose result we can
--- replicate (instead of executing them in parallel).
---
--- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary
---     computation.  Consequently, the variable case needs to deal with cases where binders are
---     in the vectoriser environments and where that is not the case.
---
-vectDictExpr :: CoreExpr -> VM CoreExpr
-vectDictExpr (Var var)
-  = do { mb_scope <- lookupVar_maybe var
-       ; case mb_scope of
-           Nothing                -> return $ Var var   -- binder from within the dict. computation
-           Just (Local (vVar, _)) -> return $ Var vVar  -- local vectorised variable
-           Just (Global vVar)     -> return $ Var vVar  -- global vectorised variable
-       }
-vectDictExpr (Lit lit)
-  = pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit)
-vectDictExpr (Lam bndr e)
-  = Lam bndr <$> vectDictExpr e
-vectDictExpr (App fn arg)
-  = App <$> vectDictExpr fn <*> vectDictExpr arg
-vectDictExpr (Case e bndr ty alts)
-  = Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts
-  where
-    vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e
-    --
-    vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon)
-      where
-        dataConErr = text "Cannot vectorise data constructor:" <+> ppr datacon
-    vectDictAltCon (LitAlt lit)      = return $ LitAlt lit
-    vectDictAltCon DEFAULT           = return DEFAULT
-vectDictExpr (Let bnd body)
-  = Let <$> vectDictBind bnd <*> vectDictExpr body
-  where
-    vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e
-    vectDictBind (Rec bnds)      = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds
-vectDictExpr e@(Cast _e _coe)
-  = pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e)
-vectDictExpr (Tick tickish e)
-  = Tick tickish <$> vectDictExpr e
-vectDictExpr (Type ty)
-  = Type <$> vectType ty
-vectDictExpr (Coercion coe)
-  = pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe)
-
--- |Vectorise an expression of functional type, where all arguments and the result are of primitive
--- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and
--- which does not contain any subcomputations that involve parallel arrays.  Such functionals do not
--- require the full blown vectorisation transformation; instead, they can be lifted by application
--- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.)
---
--- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised,
--- instead they become dictionaries of vectorised methods).  We treat them differently, though see
--- "Note [Scalar dfuns]" in 'Vectorise'.
---
-vectScalarFun :: CoreExpr -> VM VExpr
-vectScalarFun expr
-  = do
-    { traceVt "vectScalarFun:" (ppr expr)
-    ; let (arg_tys, res_ty) = splitFunTys (exprType expr)
-    ; mkScalarFun arg_tys res_ty expr
-    }
-
--- Generate code for a scalar function by generating a scalar closure.  If the function is a
--- dictionary function, vectorise it as dictionary code.
---
-mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr
-mkScalarFun arg_tys res_ty expr
-  | isPredTy res_ty
-  = do { vExpr <- vectDictExpr expr
-       ; return (vExpr, unused)
-       }
-  | otherwise
-  = do { traceVt "mkScalarFun: " $ ppr expr $$ text "  ::" <+>
-                                   ppr (mkFunTys arg_tys res_ty)
-
-       ; fn_var  <- hoistExpr (fsLit "fn") expr DontInline
-       ; zipf    <- zipScalars arg_tys res_ty
-       ; clo     <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var)
-       ; clo_var <- hoistExpr (fsLit "clo") clo DontInline
-       ; lclo    <- liftPD (Var clo_var)
-       ; return (Var clo_var, lclo)
-       }
-  where
-    unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions"
-
--- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma.
---
--- In other words, all methods in that dictionary are scalar functions — to be vectorised with
--- 'vectScalarFun'.  The dictionary "function" itself may be a constant, though.
---
--- NB: You may think that we could implement this function guided by the structure of the Core
---     expression of the right-hand side of the dictionary function.  We cannot proceed like this as
---     'vectScalarDFun' must also work for *imported* dfuns, where we don't necessarily have access
---     to the Core code of the unvectorised dfun.
---
--- Here an example — assume,
---
--- > class Eq a where { (==) :: a -> a -> Bool }
--- > instance (Eq a, Eq b) => Eq (a, b) where { (==) = ... }
--- > {-# VECTORISE SCALAR instance Eq (a, b) }
---
--- The unvectorised dfun for the above instance has the following signature:
---
--- > $dEqPair :: forall a b. Eq a -> Eq b -> Eq (a, b)
---
--- We generate the following (scalar) vectorised dfun (liberally using TH notation):
---
--- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b)
--- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b ->
--- >                D:V:Eq $(vectScalarFun True recFns
--- >                         [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |])
---
--- NB:
--- * '(,)' vectorises to '(,)' — hence, the type constructor in the result type remains the same.
--- * We share the '$(unVect di)' sub-expressions between the different selectors, but duplicate
---   the application of the unvectorised dfun, to enable the dictionary selection rules to fire.
---
-vectScalarDFun :: Var        -- ^ Original dfun
-               -> VM CoreExpr
-vectScalarDFun var
-  = do {   -- bring the type variables into scope
-       ; mapM_ defLocalTyVar tvs
-
-           -- vectorise dictionary argument types and generate variables for them
-       ; vTheta     <- mapM vectType theta
-       ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta
-       ; let vThetaVars = varsToCoreExprs vThetaBndr
-
-           -- vectorise superclass dictionaries and methods as scalar expressions
-       ; thetaVars  <- mapM (newLocalVar (fsLit "d")) theta
-       ; thetaExprs <- zipWithM unVectDict theta vThetaVars
-       ; let thetaDictBinds = zipWith NonRec thetaVars thetaExprs
-             dict           = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars
-             scsOps         = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict])
-                                  selIds
-       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps
-
-           -- vectorised applications of the class-dictionary data constructor
-       ; Just vDataCon <- lookupDataCon dataCon
-       ; vTys          <- mapM vectType tys
-       ; let vBody = thetaDictBinds `mkLets` mkCoreConApps vDataCon (map Type vTys ++ vScsOps)
-
-       ; return $ mkLams (tvs ++ vThetaBndr) vBody
-       }
-  where
-    ty                   = varType var
-    (tvs, theta, pty)    = tcSplitSigmaTy  ty        -- 'theta' is the instance context
-    (cls, tys)           = tcSplitDFunHead pty       -- 'pty' is the instance head
-    selIds               = classAllSelIds cls
-    dataCon              = classDataCon cls
-
--- Build a value of the dictionary before vectorisation from original, unvectorised type and an
--- expression computing the vectorised dictionary.
---
--- Given the vectorised version of a dictionary 'vd :: V:C vt1..vtn', generate code that computes
--- the unvectorised version, thus:
---
--- > D:C op1 .. opm
--- > where
--- >   opi = $(fromVect opTyi [| vSeli @vt1..vtk vd |])
---
--- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary.
---
-unVectDict :: Type -> CoreExpr -> VM CoreExpr
-unVectDict ty e
-  = do { vTys <- mapM vectType tys
-       ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds
-       ; scOps <- zipWithM fromVect methTys meths
-       ; return $ mkCoreConApps dataCon (map Type tys ++ scOps)
-       }
-  where
-    (tycon, tys) = splitTyConApp ty
-    Just dataCon = isDataProductTyCon_maybe tycon
-    Just cls     = tyConClass_maybe tycon
-    methTys      = dataConInstArgTys dataCon tys
-    selIds       = classAllSelIds cls
-
--- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
---
--- All non-dictionary free variables go into the closure's environment, whereas the dictionary
--- variables are passed explicit (as conventional arguments) into the body during closure
--- construction.
---
-vectLam :: Bool                 -- ^ Should the RHS of a binding be inlined?
-        -> Bool                 -- ^ Whether the binding is a loop breaker.
-        -> CoreExprWithVectInfo -- ^ Body of abstraction.
-        -> VM VExpr
-vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _)
- = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr)
-
-      ; let (bndrs, body) = collectAnnValBinders expr
-
-          -- grab the in-scope type variables
-      ; tyvars <- localTyVars
-
-          -- collect and vectorise all /local/ free variables
-      ; vfvs <- readLEnv $ \env ->
-                  [ (var, fromJust mb_vv)
-                  | var <- dVarSetElems fvs
-                  , let mb_vv = lookupVarEnv (local_vars env) var
-                  , isJust mb_vv         -- its local == is in local var env
-                  ]
-          -- separate dictionary from non-dictionary variables in the free variable set
-      ; let (vvs_dict, vvs_nondict)     = partition (isPredTy . varType . fst) vfvs
-            (_fvs_dict, vfvs_dict)      = unzip vvs_dict
-            (fvs_nondict, vfvs_nondict) = unzip vvs_nondict
-
-          -- compute the type of the vectorised closure
-      ; arg_tys <- mapM (vectType . idType) bndrs
-      ; res_ty  <- vectType (exprType $ deAnnotate body)
-
-      ; let arity      = length fvs_nondict + length bndrs
-            vfvs_dict' = map vectorised vfvs_dict
-      ; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty
-        . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity)
-        $ do {   -- generate the vectorised body of the lambda abstraction
-             ; lc              <- builtin liftingContext
-             ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) $ vectExpr body
-
-             ; vbody' <- break_loop lc res_ty vbody
-             ; return $ vLams lc vbndrs vbody'
-             }
-      }
-  where
-    maybe_inline n | inline    = Inline n
-                   | otherwise = DontInline
-
-    -- If this is the body of a binding marked as a loop breaker, add a recursion termination test
-    -- to the /lifted/ version of the function body.  The termination tests checks if the lifting
-    -- context is empty.  If so, it returns an empty array of the (lifted) result type instead of
-    -- executing the function body.  This is the test from the last line (defining \mathcal{L}')
-    -- in Figure 6 of HtM.
-    break_loop lc ty (ve, le)
-      | loop_breaker
-      = do { dflags <- getDynFlags
-           ; empty <- emptyPD ty
-           ; lty   <- mkPDataType ty
-           ; return (ve, mkWildCase (Var lc) intPrimTy lty
-                           [(DEFAULT, [], le),
-                            (LitAlt (mkMachInt dflags 0), [], empty)])
-           }
-      | otherwise = return (ve, le)
-vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda"
-
--- Vectorise an algebraic case expression.
---
--- We convert
---
---   case e :: t of v { ... }
---
--- to
---
---   V:    let v' = e in case v' of _ { ... }
---   L:    let v' = e in case v' `cast` ... of _ { ... }
---
---   When lifting, we have to do it this way because v must have the type
---   [:V(T):] but the scrutinee must be cast to the representation type. We also
---   have to handle the case where v is a wild var correctly.
---
-
--- FIXME: this is too lazy...is it?
-vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type
-            -> [(AltCon, [Var], CoreExprWithVectInfo)]
-            -> VM VExpr
-vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
-  = do
-    { traceVt "scrutinee (DEFAULT only)" Outputable.empty
-    ; vscrut         <- vectExpr scrut
-    ; (vty, lty)     <- vectAndLiftType ty
-    ; traceVt "alternative body (DEFAULT only)" Outputable.empty
-    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
-    ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody
-    }
-vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
-  = do
-    { traceVt "scrutinee (one shot w/o binders)" Outputable.empty
-    ; vscrut         <- vectExpr scrut
-    ; (vty, lty)     <- vectAndLiftType ty
-    ; traceVt "alternative body (one shot w/o binders)" Outputable.empty
-    ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
-    ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody
-    }
-vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
-  = do
-    { traceVt "scrutinee (one shot w/ binders)" Outputable.empty
-    ; vexpr      <- vectExpr scrut
-    ; (vty, lty) <- vectAndLiftType ty
-    ; traceVt "alternative body (one shot w/ binders)" Outputable.empty
-    ; (vbndr, (vbndrs, (vect_body, lift_body)))
-        <- vect_scrut_bndr
-         . vectBndrsIn bndrs
-         $ vectExpr body
-    ; let (vect_bndrs, lift_bndrs) = unzip vbndrs
-    ; (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)
-    ; vect_dc <- maybeV dataConErr (lookupDataCon dc)
-
-    ; let vcase = mk_wild_case vscrut vty vect_dc  vect_bndrs vect_body
-          lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body
-
-    ; return $ vLet (vNonRec vbndr vexpr) (vcase, lcase)
-    }
-  where
-    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
-                    | otherwise         = vectBndrIn bndr
-
-    mk_wild_case expr ty dc bndrs body
-      = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)]
-
-    dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)
-
-vectAlgCase tycon _ty_args scrut bndr ty alts
-  = do
-    { traceVt "scrutinee (general case)" Outputable.empty
-    ; vexpr <- vectExpr scrut
-
-    ; vect_tc     <- vectTyCon tycon
-    ; (vty, lty)  <- vectAndLiftType ty
-
-    ; let arity = length (tyConDataCons vect_tc)
-    ; sel_ty <- builtin (selTy arity)
-    ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty
-    ; let sel = Var sel_bndr
-
-    ; traceVt "alternatives' body (general case)" Outputable.empty
-    ; (vbndr, valts) <- vect_scrut_bndr
-                      $ mapM (proc_alt arity sel vty lty) alts'
-    ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
-
-    ; (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)
-
-    ; let (vect_bodies, lift_bodies) = unzip vbodies
-
-    ; vdummy <- newDummyVar (exprType vect_scrut)
-    ; ldummy <- newDummyVar (exprType lift_scrut)
-    ; let vect_case = Case vect_scrut vdummy vty
-                           (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies)
-
-    ; lc <- builtin liftingContext
-    ; lbody <- combinePD vty (Var lc) sel lift_bodies
-    ; let lift_case = Case lift_scrut ldummy lty
-                           [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss,
-                             lbody)]
-
-    ; return . vLet (vNonRec vbndr vexpr)
-             $ (vect_case, lift_case)
-    }
-  where
-    vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut")
-                    | otherwise         = vectBndrIn bndr
-
-    alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts
-
-    cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2
-    cmp DEFAULT       DEFAULT       = EQ
-    cmp DEFAULT       _             = LT
-    cmp _             DEFAULT       = GT
-    cmp _             _             = panic "vectAlgCase/cmp"
-
-    proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _))
-      = do
-          dflags <- getDynFlags
-          vect_dc <- maybeV dataConErr (lookupDataCon dc)
-          let ntag = dataConTagZ vect_dc
-              tag  = mkDataConTag dflags vect_dc
-              fvs  = fvs_body `delDVarSetList` bndrs
-
-          sel_tags  <- liftM (`App` sel) (builtin (selTags arity))
-          lc        <- builtin liftingContext
-          elems     <- builtin (selElements arity ntag)
-
-          (vbndrs, vbody)
-            <- vectBndrsIn bndrs
-             . localV
-             $ do
-               { binds    <- mapM (pack_var (Var lc) sel_tags tag)
-                           . filter isLocalId
-                           $ dVarSetElems fvs
-               ; traceVt "case alternative:" (ppr . deAnnotate $ body)
-               ; (ve, le) <- vectExpr body
-               ; return (ve, Case (elems `App` sel) lc lty
-                             [(DEFAULT, [], (mkLets (concat binds) le))])
-               }
-                 -- empty    <- emptyPD vty
-                 -- return (ve, Case (elems `App` sel) lc lty
-                 --             [(DEFAULT, [], Let (NonRec flags_var flags_expr)
-                 --                             $ mkLets (concat binds) le),
-                 --               (LitAlt (mkMachInt 0), [], empty)])
-          let (vect_bndrs, lift_bndrs) = unzip vbndrs
-          return (vect_dc, vect_bndrs, lift_bndrs, vbody)
-      where
-        dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc)
-
-    proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt"
-
-    mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body)
-
-      -- Pack a variable for a case alternative context *if* the variable is vectorised. If it
-      -- isn't, ignore it as scalar variables don't need to be packed.
-    pack_var len tags t v
-      = do
-        { r <- lookupVar_maybe v
-        ; case r of
-            Just (Local (vv, lv)) ->
-              do
-              { lv'  <- cloneVar lv
-              ; expr <- packByTagPD (idType vv) (Var lv) len tags t
-              ; updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') })
-              ; return [(NonRec lv' expr)]
-              }
-            _ -> return []
-        }
-
-
--- Support to compute information for vectorisation avoidance ------------------
-
--- Annotation for Core AST nodes that describes how they should be handled during vectorisation
--- and especially if vectorisation of the corresponding computation can be avoided.
---
-data VectAvoidInfo = VIParr       -- tree contains parallel computations
-                   | VISimple     -- result type is scalar & no parallel subcomputation
-                   | VIComplex    -- any result type, no parallel subcomputation
-                   | VIEncaps     -- tree encapsulated by 'liftSimple'
-                   | VIDict       -- dictionary computation (never parallel)
-                   deriving (Eq, Show)
-
--- Core expression annotated with free variables and vectorisation-specific information.
---
-type CoreExprWithVectInfo = AnnExpr Id (DVarSet, VectAvoidInfo)
-
--- Yield the type of an annotated core expression.
---
-annExprType :: AnnExpr Var ann -> Type
-annExprType = exprType . deAnnotate
-
--- Project the vectorisation information from an annotated Core expression.
---
-vectAvoidInfoOf :: CoreExprWithVectInfo -> VectAvoidInfo
-vectAvoidInfoOf ((_, vi), _) = vi
-
--- Is this a 'VIParr' node?
---
-isVIParr :: CoreExprWithVectInfo -> Bool
-isVIParr = (== VIParr) . vectAvoidInfoOf
-
--- Is this a 'VIEncaps' node?
---
-isVIEncaps :: CoreExprWithVectInfo -> Bool
-isVIEncaps = (== VIEncaps) . vectAvoidInfoOf
-
--- Is this a 'VIDict' node?
---
-isVIDict :: CoreExprWithVectInfo -> Bool
-isVIDict = (== VIDict) . vectAvoidInfoOf
-
--- 'VIParr' if either argument is 'VIParr'; otherwise, the first argument.
---
-unlessVIParr :: VectAvoidInfo -> VectAvoidInfo -> VectAvoidInfo
-unlessVIParr _  VIParr = VIParr
-unlessVIParr vi _      = vi
-
--- 'VIParr' if either arguments vectorisation information is 'VIParr'; otherwise, the vectorisation
--- information of the first argument is produced.
---
-unlessVIParrExpr :: VectAvoidInfo -> CoreExprWithVectInfo -> VectAvoidInfo
-infixl `unlessVIParrExpr`
-unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2
-
--- Compute Core annotations to determine for which subexpressions we can avoid vectorisation.
---
--- * The first argument is the set of free, local variables whose evaluation may entail parallelism.
---
-vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo
-vectAvoidInfo pvs ce@(_, AnnVar v)
-  = do
-    { gpvs <- globalParallelVars
-    ; vi <- if v `elemVarSet` pvs || v `elemDVarSet` gpvs
-            then return VIParr
-            else vectAvoidInfoTypeOf ce
-    ; viTrace ce vi []
-    ; when (vi == VIParr) $
-        traceVt "  reason:" $ if v `elemVarSet` pvs  then text "local"  else
-                              if v `elemDVarSet` gpvs then text "global" else text "parallel type"
-
-    ; return ((fvs, vi), AnnVar v)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo _pvs ce@(_, AnnLit lit)
-  = do
-    { vi <- vectAvoidInfoTypeOf ce
-    ; viTrace ce vi []
-    ; return ((fvs, vi), AnnLit lit)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo pvs ce@(_, AnnApp e1 e2)
-  = do
-    { ceVI <- vectAvoidInfoTypeOf ce
-    ; eVI1 <- vectAvoidInfo pvs e1
-    ; eVI2 <- vectAvoidInfo pvs e2
-    ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2
-    -- ; viTrace ce vi [eVI1, eVI2]
-    ; return ((fvs, vi), AnnApp eVI1 eVI2)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo pvs ce@(_, AnnLam var body)
-  = do
-    { bodyVI <- vectAvoidInfo pvs body
-    ; varVI  <- vectAvoidInfoType $ varType var
-    ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI
-    -- ; viTrace ce vi [bodyVI]
-    ; return ((fvs, vi), AnnLam var bodyVI)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body)
-  = do
-    { ceVI       <- vectAvoidInfoTypeOf ce
-    ; eVI        <- vectAvoidInfo pvs e
-    ; isScalarTy <- isScalar $ varType var
-    ; (bodyVI, vi) <- if isVIParr eVI && not isScalarTy
-        then do -- binding is parallel
-        { bodyVI <- vectAvoidInfo (pvs `extendVarSet` var) body
-        ; return (bodyVI, VIParr)
-        }
-        else do -- binding doesn't affect parallelism
-        { bodyVI <- vectAvoidInfo pvs body
-        ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI)
-        }
-    -- ; viTrace ce vi [eVI, bodyVI]
-    ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body)
-  = do
-    { ceVI         <- vectAvoidInfoTypeOf ce
-    ; bndsVI       <- mapM (vectAvoidInfoBnd pvs) bnds
-    ; parrBndrs    <- map fst <$> filterM isVIParrBnd bndsVI
-    ; if not . null $ parrBndrs
-      then do         -- body may trigger parallelism via at least one binding
-        { new_pvs <- filterM ((not <$>) . isScalar . varType) parrBndrs
-        ; let extendedPvs = pvs `extendVarSetList` new_pvs
-        ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds
-        ; bodyVI <- vectAvoidInfo extendedPvs body
-        -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI])
-        ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI)
-        }
-      else do         -- demanded bindings cannot trigger parallelism
-        { bodyVI <- vectAvoidInfo pvs body
-        ; let vi = ceVI `unlessVIParrExpr` bodyVI
-        -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI])
-        ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI)
-        }
-    }
-  where
-    fvs = freeVarsOf ce
-    vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e
-
-    isVIParrBnd (var, eVI)
-      = do
-        { isScalarTy <- isScalar (varType var)
-        ; return $ isVIParr eVI && not isScalarTy
-        }
-
-vectAvoidInfo pvs ce@(_, AnnCase e var ty alts)
-  = do
-    { ceVI           <- vectAvoidInfoTypeOf ce
-    ; eVI            <- vectAvoidInfo pvs e
-    ; altsVI         <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts
-    ; let alteVIs = [eVI | (_, _, eVI) <- altsVI]
-          vi      =  foldl unlessVIParrExpr ceVI (eVI:alteVIs)  -- NB: same effect as in the paper
-    -- ; viTrace ce vi (eVI : alteVIs)
-    ; return ((fvs, vi), AnnCase eVI var ty altsVI)
-    }
-  where
-    fvs = freeVarsOf ce
-    vectAvoidInfoAlt scrutIsPar (con, bndrs, e)
-      = do
-        { allScalar <- allScalarVarType bndrs
-        ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs
-                     | otherwise                   = pvs
-        ; (con, bndrs,) <$> vectAvoidInfo altPvs e
-        }
-
-vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann))
-  = do
-    { eVI <- vectAvoidInfo pvs e
-    ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((freeVarsOfAnn fvs_ann, VISimple), ann))
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo pvs ce@(_, AnnTick tick e)
-  = do
-    { eVI <- vectAvoidInfo pvs e
-    ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI)
-    }
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo _pvs ce@(_, AnnType ty)
-  = return ((fvs, VISimple), AnnType ty)
-  where
-    fvs = freeVarsOf ce
-
-vectAvoidInfo _pvs ce@(_, AnnCoercion coe)
-  = return ((fvs, VISimple), AnnCoercion coe)
-  where
-    fvs = freeVarsOf ce
-
--- Compute vectorisation avoidance information for a type.
---
-vectAvoidInfoType :: Type -> VM VectAvoidInfo
-vectAvoidInfoType ty
-  | isPredTy ty
-  = return VIDict
-  | Just (arg, res) <- splitFunTy_maybe ty
-  = do
-    { argVI <- vectAvoidInfoType arg
-    ; resVI <- vectAvoidInfoType res
-    ; case (argVI, resVI) of
-        (VISimple, VISimple) -> return VISimple   -- NB: diverts from the paper: scalar functions
-        (_       , VIDict)   -> return VIDict
-        _                    -> return $ VIComplex `unlessVIParr` argVI `unlessVIParr` resVI
-    }
-  | otherwise
-  = do
-    { parr <- maybeParrTy ty
-    ; if parr
-      then return VIParr
-      else do
-    { scalar <- isScalar ty
-    ; if scalar
-      then return VISimple
-      else return VIComplex
-    } }
-
--- Compute vectorisation avoidance information for the type of a Core expression (with FVs).
---
-vectAvoidInfoTypeOf :: AnnExpr Var ann -> VM VectAvoidInfo
-vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType
-
--- Checks whether the type might be a parallel array type.
---
-maybeParrTy :: Type -> VM Bool
-maybeParrTy ty
-    -- looking through newtypes
-  | Just ty'      <- coreView ty
-  = (== VIParr) <$> vectAvoidInfoType ty'
-    -- decompose constructor applications
-  | Just (tc, ts) <- splitTyConApp_maybe ty
-  = do
-    { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons
-    ; if isParallel
-      then return True
-      else or <$> mapM maybeParrTy ts
-    }
-  -- must be a Named ForAllTy because anon ones respond to splitTyConApp_maybe
-maybeParrTy (ForAllTy _ ty) = maybeParrTy ty
-maybeParrTy _               = return False
-
--- Are the types of all variables in the 'Scalar' class or toplevel variables?
---
--- NB: 'liftSimple' does not abstract over toplevel variables.
---
-allScalarVarType :: [Var] -> VM Bool
-allScalarVarType vs = and <$> mapM isScalarOrToplevel vs
-  where
-    isScalarOrToplevel v | isToplevel v = return True
-                         | otherwise    = isScalar (varType v)
-
--- Are the types of all variables in the set in the 'Scalar' class or toplevel variables?
---
-allScalarVarTypeSet :: DVarSet -> VM Bool
-allScalarVarTypeSet = allScalarVarType . dVarSetElems
-
--- Debugging support
---
-viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM ()
-viTrace ce vi vTs
-  = traceVt ("vect info: " ++ show vi ++ "[" ++
-             (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]")
-            (ppr $ deAnnotate ce)
diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs
deleted file mode 100644
index 78a8f2c192..0000000000
--- a/compiler/vectorise/Vectorise/Generic/Description.hs
+++ /dev/null
@@ -1,292 +0,0 @@
--- |Compute a description of the generic representation that we use for a user defined data type.
---
--- During vectorisation, we generate a PRepr and PA instance for each user defined
--- data type. The PA dictionary contains methods to convert the user type to and
--- from our generic representation. This module computes a description of what
--- that generic representation is.
---
-module Vectorise.Generic.Description
-  ( CompRepr(..)
-  , ProdRepr(..)
-  , ConRepr(..)
-  , SumRepr(..)
-  , tyConRepr
-  , sumReprType
-  , compOrigType
-  )
-where
-
-import Vectorise.Utils
-import Vectorise.Monad
-import Vectorise.Builtins
-
-import CoreSyn
-import DataCon
-import TyCon
-import Type
-import Control.Monad
-import Outputable
-
-
--- | Describes the generic representation of a data type.
---   If the data type has multiple constructors then we bundle them
---   together into a generic sum type.
-data SumRepr
-        =  -- | Data type has no data constructors.
-           EmptySum
-
-        -- | Data type has a single constructor.
-        | UnarySum ConRepr
-
-        -- | Data type has multiple constructors.
-        | Sum  { -- | Representation tycon for the sum (eg Sum2)
-                 repr_sum_tc    :: TyCon
-
-               -- | PData version of the sum tycon     (eg PDataSum2)
-               --   This TyCon doesn't appear explicitly in the source program.
-               --   See Note [PData TyCons].
-               , repr_psum_tc   :: TyCon
-
-               -- | PDatas version of the sum tycon    (eg PDatasSum2)
-               , repr_psums_tc  :: TyCon
-
-               -- | Type of the selector               (eg Sel2)
-               , repr_sel_ty    :: Type
-
-               -- | Type of multi-selector             (eg Sel2s)
-               , repr_sels_ty   :: Type
-
-               -- | Function to get the length of a Sels of this type.
-               , repr_selsLength_v :: CoreExpr
-
-               -- | Type of each data constructor.
-               , repr_con_tys   :: [Type]
-
-               -- | Generic representation types of each data constructor.
-               , repr_cons      :: [ConRepr]
-               }
-
-
--- | Describes the representation type of a data constructor.
-data ConRepr
-        = ConRepr
-                { repr_dc       :: DataCon
-                , repr_prod     :: ProdRepr
-                }
-
--- | Describes the representation type of the fields \/ components of a constructor.
---   If the data constructor has multiple fields then we bundle them
---   together into a generic product type.
-data ProdRepr
-        = -- | Data constructor has no fields.
-          EmptyProd
-
-        -- | Data constructor has a single field.
-        | UnaryProd CompRepr
-
-        -- | Data constructor has several fields.
-        | Prod { -- | Representation tycon for the product (eg Tuple2)
-                 repr_tup_tc   :: TyCon
-
-                 -- | PData  version of the product tycon  (eg PDataTuple2)
-               , repr_ptup_tc  :: TyCon
-
-                 -- | PDatas version of the product tycon  (eg PDatasTuple2s)
-                 --   Not all lifted backends use `PDatas`.
-               , repr_ptups_tc :: TyCon
-
-                 -- | Types of each field.
-               , repr_comp_tys :: [Type]
-
-                 -- | Generic representation types for each field.
-               , repr_comps    :: [CompRepr]
-               }
-
-
--- | Describes the representation type of a data constructor field.
-data CompRepr
-        = Keep Type
-               CoreExpr     -- PR dictionary for the type
-        | Wrap Type
-
-
--------------------------------------------------------------------------------
-
--- |Determine the generic representation of a data type, given its tycon.
---
-tyConRepr :: TyCon -> VM SumRepr
-tyConRepr tc
-  = sum_repr (tyConDataCons tc)
-  where
-    -- Build the representation type for a data type with the given constructors.
-    -- The representation types for each individual constructor are bundled
-    -- together into a generic sum type.
-    sum_repr :: [DataCon] -> VM SumRepr
-    sum_repr []    = return EmptySum
-    sum_repr [con] = liftM UnarySum (con_repr con)
-    sum_repr cons
-     = do  let arity    = length cons
-           rs           <- mapM con_repr cons
-           tys          <- mapM conReprType rs
-
-           -- Get the 'Sum' tycon of this arity (eg Sum2).
-           sum_tc       <- builtin (sumTyCon arity)
-
-           -- Get the 'PData' and 'PDatas' tycons for the sum.
-           psum_tc      <- pdataReprTyConExact  sum_tc
-           psums_tc     <- pdatasReprTyConExact sum_tc
-
-           sel_ty       <- builtin (selTy      arity)
-           sels_ty      <- builtin (selsTy     arity)
-           selsLength_v <- builtin (selsLength arity)
-           return $ Sum
-                  { repr_sum_tc         = sum_tc
-                  , repr_psum_tc        = psum_tc
-                  , repr_psums_tc       = psums_tc
-                  , repr_sel_ty         = sel_ty
-                  , repr_sels_ty        = sels_ty
-                  , repr_selsLength_v   = selsLength_v
-                  , repr_con_tys        = tys
-                  , repr_cons           = rs
-                  }
-
-    -- Build the representation type for a single data constructor.
-    con_repr con   = liftM (ConRepr con) (prod_repr (dataConRepArgTys con))
-
-    -- Build the representation type for the fields of a data constructor.
-    -- The representation types for each individual field are bundled
-    -- together into a generic product type.
-    prod_repr :: [Type] -> VM ProdRepr
-    prod_repr []   = return EmptyProd
-    prod_repr [ty] = liftM UnaryProd (comp_repr ty)
-    prod_repr tys
-     = do  let arity    = length tys
-           rs           <- mapM comp_repr tys
-           tys'         <- mapM compReprType rs
-
-           -- Get the Prod \/ Tuple tycon of this arity (eg Tuple2)
-           tup_tc       <- builtin (prodTyCon arity)
-
-           -- Get the 'PData' and 'PDatas' tycons for the product.
-           ptup_tc      <- pdataReprTyConExact  tup_tc
-           ptups_tc     <- pdatasReprTyConExact tup_tc
-
-           return $ Prod
-                  { repr_tup_tc   = tup_tc
-                  , repr_ptup_tc  = ptup_tc
-                  , repr_ptups_tc = ptups_tc
-                  , repr_comp_tys = tys'
-                  , repr_comps    = rs
-                  }
-
-    -- Build the representation type for a single data constructor field.
-    comp_repr ty = liftM (Keep ty) (prDictOfReprType ty)
-                   `orElseV` return (Wrap ty)
-
--- |Yield the type of this sum representation.
---
-sumReprType :: SumRepr -> VM Type
-sumReprType EmptySum     = voidType
-sumReprType (UnarySum r) = conReprType r
-sumReprType (Sum { repr_sum_tc  = sum_tc, repr_con_tys = tys })
-  = return $ mkTyConApp sum_tc tys
-
--- Yield the type of this constructor representation.
---
-conReprType :: ConRepr -> VM Type
-conReprType (ConRepr _ r) = prodReprType r
-
--- Yield the type of of this product representation.
---
-prodReprType :: ProdRepr -> VM Type
-prodReprType EmptyProd     = voidType
-prodReprType (UnaryProd r) = compReprType r
-prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })
-  = return $ mkTyConApp tup_tc tys
-
--- Yield the type of this data constructor field \/ component representation.
---
-compReprType :: CompRepr -> VM Type
-compReprType (Keep ty _) = return ty
-compReprType (Wrap ty)   = mkWrapType ty
-
--- |Yield the original component type of a data constructor component representation.
---
-compOrigType :: CompRepr -> Type
-compOrigType (Keep ty _) = ty
-compOrigType (Wrap ty)   = ty
-
-
--- Outputable instances -------------------------------------------------------
-instance Outputable SumRepr where
- ppr ss
-  = case ss of
-        EmptySum
-         -> text "EmptySum"
-
-        UnarySum con
-         -> sep [text "UnarySum", ppr con]
-
-        Sum sumtc psumtc psumstc selty selsty selsLength contys cons
-         -> text "Sum" $+$ braces (nest 4
-                $ sep   [ text "repr_sum_tc       = " <> ppr sumtc
-                        , text "repr_psum_tc      = " <> ppr psumtc
-                        , text "repr_psums_tc     = " <> ppr psumstc
-                        , text "repr_sel_ty       = " <> ppr selty
-                        , text "repr_sels_ty      = " <> ppr selsty
-                        , text "repr_selsLength_v = " <> ppr selsLength
-                        , text "repr_con_tys      = " <> ppr contys
-                        , text "repr_cons         = " <> ppr cons])
-
-
-instance Outputable ConRepr where
- ppr (ConRepr dc pr)
-        = text "ConRepr" $+$ braces (nest 4
-                $ sep   [ text "repr_dc      = " <> ppr dc
-                        , text "repr_prod    = " <> ppr pr])
-
-
-instance Outputable ProdRepr where
- ppr ss
-  = case ss of
-        EmptyProd
-         -> text "EmptyProd"
-
-        UnaryProd cr
-         -> sep [text "UnaryProd", ppr cr]
-
-        Prod tuptcs ptuptcs ptupstcs comptys comps
-         -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps]
-
-
-instance Outputable CompRepr where
- ppr ss
-  = case ss of
-        Keep t ce
-         -> text "Keep" $+$ sep [ppr t, ppr ce]
-
-        Wrap t
-         -> sep [text "Wrap", ppr t]
-
-
--- Notes ----------------------------------------------------------------------
-{-
-Note [PData TyCons]
-~~~~~~~~~~~~~~~~~~~
-When PData is a type family, the compiler generates a type constructor for each
-instance, which is named after the family and instance type. This type
-constructor does not appear in the source program. Rather, it is implicitly
-defined by the data instance. For example with:
-
-  data family PData a
-
-  data instance PData (Sum2 a b)
-        = PSum2  U.Sel2
-                 (PData a)
-                 (PData b)
-
-The type constructor corresponding to the instance will be named 'PDataSum2',
-and this is what we will get in the repr_psum_tc field of SumRepr.Sum.
-
--}
-
diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs
deleted file mode 100644
index 5b7748a499..0000000000
--- a/compiler/vectorise/Vectorise/Generic/PADict.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-
-module Vectorise.Generic.PADict
-  ( buildPADict
-  ) where
-
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Generic.Description
-import Vectorise.Generic.PAMethods ( buildPAScAndMethods )
-import Vectorise.Utils
-
-import BasicTypes
-import CoreSyn
-import CoreUtils
-import CoreUnfold
-import Module
-import TyCon
-import CoAxiom
-import Type
-import Id
-import Var
-import Name
-import FastString
-
-
--- |Build the PA dictionary function for some type and hoist it to top level.
---
--- The PA dictionary holds fns that convert values to and from their vectorised representations.
---
--- @Recall the definition:
---    class PR (PRepr a) => PA a where
---      toPRepr      :: a -> PRepr a
---      fromPRepr    :: PRepr a -> a
---      toArrPRepr   :: PData a -> PData (PRepr a)
---      fromArrPRepr :: PData (PRepr a) -> PData a
---      toArrPReprs   :: PDatas a         -> PDatas (PRepr a)
---      fromArrPReprs :: PDatas (PRepr a) -> PDatas a
---
--- Example:
---    df :: forall a. PR (PRepr a) -> PA a -> PA (T a)
---    df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ...
---    $dPR_df :: forall a. PA a -> PR (PRepr (T a))
---    $dPR_df = ....
---    $toRepr :: forall a. PA a -> T a -> PRepr (T a)
---    $toPRepr = ...
--- The "..." stuff is filled in by buildPAScAndMethods
--- @
---
-buildPADict
-        :: TyCon        -- ^ tycon of the type being vectorised.
-        -> CoAxiom Unbranched
-                        -- ^ Coercion between the type and
-                        --     its vectorised representation.
-        -> TyCon        -- ^ PData  instance tycon
-        -> TyCon        -- ^ PDatas instance tycon
-        -> SumRepr      -- ^ representation used for the type being vectorised.
-        -> VM Var       -- ^ name of the top-level dictionary function.
-
-buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
- = polyAbstract tvs $ \args ->    -- The args are the dictionaries we lambda abstract over; and they
-                                  -- are put in the envt, so when we need a (PA a) we can find it in
-                                  -- the envt; they don't include the silent superclass args yet
-   do { mod <- liftDs getModule
-      ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name
-
-          -- The superclass dictionary is a (silent) argument if the tycon is polymorphic...
-      ; let mk_super_ty = do { r <- mkPReprType inst_ty
-                             ; pr_cls <- builtin prClass
-                             ; return $ mkClassPred pr_cls [r]
-                             }
-      ; super_tys  <- sequence [mk_super_ty | not (null tvs)]
-      ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys
-      ; let val_args = super_args ++ args
-            all_args = tvs ++ val_args
-
-          -- ...it is constant otherwise
-      ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs]
-
-          -- Get ids for each of the methods in the dictionary, including superclass
-      ; paMethodBuilders <- buildPAScAndMethods
-      ; method_ids       <- mapM (method val_args dfun_name) paMethodBuilders
-
-          -- Expression to build the dictionary.
-      ; pa_dc  <- builtin paDataCon
-      ; let dict = mkLams all_args (mkConApp pa_dc con_args)
-            con_args = Type inst_ty
-                     : map Var super_args  -- the superclass dictionary is either
-                    ++ super_consts        -- lambda-bound or constant
-                    ++ map (method_call val_args) method_ids
-
-          -- Build the type of the dictionary function.
-      ; pa_cls <- builtin paClass
-      ; let dfun_ty = mkInvForAllTys tvs
-                    $ mkFunTys (map varType val_args)
-                               (mkClassPred pa_cls [inst_ty])
-
-          -- Set the unfolding for the inliner.
-      ; raw_dfun <- newExportedVar dfun_name dfun_ty
-      ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args
-            dfun = raw_dfun `setIdUnfolding`  dfun_unf
-                            `setInlinePragma` dfunInlinePragma
-
-          -- Add the new binding to the top-level environment.
-      ; hoistBinding dfun dict
-      ; return dfun
-      }
-  where
-    tvs          = tyConTyVars vect_tc
-    arg_tys      = mkTyVarTys tvs
-    inst_ty      = mkTyConApp vect_tc arg_tys
-    vect_tc_name = getName vect_tc
-
-    method args dfun_name (name, build)
-     = localV
-     $ do  expr     <- build vect_tc prepr_ax pdata_tc pdatas_tc repr
-           let body = mkLams (tvs ++ args) expr
-           raw_var  <- newExportedVar (method_name dfun_name name) (exprType body)
-           let var  = raw_var
-                      `setIdUnfolding` mkInlineUnfoldingWithArity
-                                         (length args) body
-                      `setInlinePragma` alwaysInlinePragma
-           hoistBinding var body
-           return var
-
-    method_call args id        = mkApps (Var id) (map Type arg_tys ++ map Var args)
-    method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs
deleted file mode 100644
index d480ea926b..0000000000
--- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs
+++ /dev/null
@@ -1,584 +0,0 @@
-
--- | Generate methods for the PA class.
---
---   TODO: there is a large amount of redundancy here between the
---   a, PData a, and PDatas a forms. See if we can factor some of this out.
---
-module Vectorise.Generic.PAMethods
-  ( buildPReprTyCon
-  , buildPAScAndMethods
-  ) where
-
-import Vectorise.Utils
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Generic.Description
-import CoreSyn
-import CoreUtils
-import FamInstEnv
-import MkCore            ( mkWildCase, mkCoreLet )
-import TyCon
-import CoAxiom
-import Type
-import OccName
-import Coercion
-import MkId
-import FamInst
-import TysPrim( intPrimTy )
-
-import DynFlags
-import FastString
-import MonadUtils
-import Control.Monad
-import Outputable
-
-
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPReprTyCon orig_tc vect_tc repr
- = do name      <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
-      rhs_ty    <- sumReprType repr
-      prepr_tc  <- builtin preprTyCon
-      let axiom = mkSingleCoAxiom Nominal name tyvars [] prepr_tc instTys rhs_ty
-      liftDs $ newFamInst SynFamilyInst axiom
-  where
-    tyvars = tyConTyVars vect_tc
-    instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]
-
--- buildPAScAndMethods --------------------------------------------------------
-
--- | This says how to build the PR superclass and methods of PA
---   Recall the definition of the PA class:
---
---   @
---    class class PR (PRepr a) => PA a where
---      toPRepr       :: a                -> PRepr a
---      fromPRepr     :: PRepr a          -> a
---
---      toArrPRepr    :: PData a          -> PData (PRepr a)
---      fromArrPRepr  :: PData (PRepr a)  -> PData a
---
---      toArrPReprs   :: PDatas a         -> PDatas (PRepr a)
---      fromArrPReprs :: PDatas (PRepr a) -> PDatas a
---   @
---
-type PAInstanceBuilder
-        =  TyCon        -- ^ Vectorised TyCon
-        -> CoAxiom Unbranched
-                        -- ^ Coercion to the representation TyCon
-        -> TyCon        -- ^ 'PData'  TyCon
-        -> TyCon        -- ^ 'PDatas' TyCon
-        -> SumRepr      -- ^ Description of generic representation.
-        -> VM CoreExpr  -- ^ Instance function.
-
-
-buildPAScAndMethods :: VM [(String, PAInstanceBuilder)]
-buildPAScAndMethods
- = return [ ("toPRepr",       buildToPRepr)
-          , ("fromPRepr",     buildFromPRepr)
-          , ("toArrPRepr",    buildToArrPRepr)
-          , ("fromArrPRepr",  buildFromArrPRepr)
-          , ("toArrPReprs",   buildToArrPReprs)
-          , ("fromArrPReprs", buildFromArrPReprs)]
-
-
--- buildToPRepr ---------------------------------------------------------------
--- | Build the 'toRepr' method of the PA class.
-buildToPRepr :: PAInstanceBuilder
-buildToPRepr vect_tc repr_ax _ _ repr
- = do let arg_ty = mkTyConApp vect_tc ty_args
-
-      -- Get the representation type of the argument.
-      res_ty <- mkPReprType arg_ty
-
-      -- Var to bind the argument
-      arg    <- newLocalVar (fsLit "x") arg_ty
-
-      -- Build the expression to convert the argument to the generic representation.
-      result <- to_sum (Var arg) arg_ty res_ty repr
-
-      return $ Lam arg result
-  where
-    ty_args        = mkTyVarTys (tyConTyVars vect_tc)
-
-    wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args []
-
-    -- CoreExp to convert the given argument to the generic representation.
-    -- We start by doing a case branch on the possible data constructors.
-    to_sum :: CoreExpr -> Type -> Type -> SumRepr -> VM CoreExpr
-    to_sum _ _ _ EmptySum
-     = do void <- builtin voidVar
-          return $ wrap_repr_inst $ Var void
-
-    to_sum arg arg_ty res_ty (UnarySum r)
-     = do (pat, vars, body) <- con_alt r
-          return $ mkWildCase arg arg_ty res_ty
-                   [(pat, vars, wrap_repr_inst body)]
-
-    to_sum arg arg_ty res_ty (Sum { repr_sum_tc  = sum_tc
-                                  , repr_con_tys = tys
-                                  , repr_cons    =  cons })
-     = do alts <- mapM con_alt cons
-          let alts' = [(pat, vars, wrap_repr_inst
-                                   $ mkConApp sum_con (map Type tys ++ [body]))
-                        | ((pat, vars, body), sum_con)
-                            <- zip alts (tyConDataCons sum_tc)]
-          return $ mkWildCase arg arg_ty res_ty alts'
-
-    con_alt (ConRepr con r)
-     = do (vars, body) <- to_prod r
-          return (DataAlt con, vars, body)
-
-    -- CoreExp to convert data constructor fields to the generic representation.
-    to_prod :: ProdRepr -> VM ([Var], CoreExpr)
-    to_prod EmptyProd
-     = do void <- builtin voidVar
-          return ([], Var void)
-
-    to_prod (UnaryProd comp)
-     = do var  <- newLocalVar (fsLit "x") (compOrigType comp)
-          body <- to_comp (Var var) comp
-          return ([var], body)
-
-    to_prod (Prod { repr_tup_tc   = tup_tc
-                  , repr_comp_tys = tys
-                  , repr_comps    = comps })
-     = do vars  <- newLocalVars (fsLit "x") (map compOrigType comps)
-          exprs <- zipWithM to_comp (map Var vars) comps
-          let [tup_con] = tyConDataCons tup_tc
-          return (vars, mkConApp tup_con (map Type tys ++ exprs))
-
-    -- CoreExp to convert a data constructor component to the generic representation.
-    to_comp :: CoreExpr -> CompRepr -> VM CoreExpr
-    to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfWrap expr ty
-
-
--- buildFromPRepr -------------------------------------------------------------
-
--- |Build the 'fromPRepr' method of the PA class.
---
-buildFromPRepr :: PAInstanceBuilder
-buildFromPRepr vect_tc repr_ax _ _ repr
-  = do
-      arg_ty <- mkPReprType res_ty
-      arg <- newLocalVar (fsLit "x") arg_ty
-
-      result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg))
-                         repr
-      return $ Lam arg result
-  where
-    ty_args = mkTyVarTys (tyConTyVars vect_tc)
-    res_ty  = mkTyConApp vect_tc ty_args
-
-    from_sum _ EmptySum
-     = do dummy <- builtin fromVoidVar
-          return $ Var dummy `App` Type res_ty
-
-    from_sum expr (UnarySum r) = from_con expr r
-    from_sum expr (Sum { repr_sum_tc  = sum_tc
-                       , repr_con_tys = tys
-                       , repr_cons    = cons })
-     = do vars  <- newLocalVars (fsLit "x") tys
-          es    <- zipWithM from_con (map Var vars) cons
-          return $ mkWildCase expr (exprType expr) res_ty
-                   [(DataAlt con, [var], e)
-                      | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es]
-
-    from_con expr (ConRepr con r)
-      = from_prod expr (mkConApp con $ map Type ty_args) r
-
-    from_prod _ con EmptyProd = return con
-    from_prod expr con (UnaryProd r)
-     = do e <- from_comp expr r
-          return $ con `App` e
-
-    from_prod expr con (Prod { repr_tup_tc   = tup_tc
-                             , repr_comp_tys = tys
-                             , repr_comps    = comps
-                             })
-     = do vars <- newLocalVars (fsLit "y") tys
-          es   <- zipWithM from_comp (map Var vars) comps
-          let [tup_con] = tyConDataCons tup_tc
-          return $ mkWildCase expr (exprType expr) res_ty
-                   [(DataAlt tup_con, vars, con `mkApps` es)]
-
-    from_comp expr (Keep _ _) = return expr
-    from_comp expr (Wrap ty)  = unwrapNewTypeBodyOfWrap expr ty
-
-
--- buildToArrRepr -------------------------------------------------------------
-
--- |Build the 'toArrRepr' method of the PA class.
---
-buildToArrPRepr :: PAInstanceBuilder
-buildToArrPRepr vect_tc repr_co pdata_tc _ r
- = do arg_ty <- mkPDataType el_ty
-      res_ty <- mkPDataType =<< mkPReprType el_ty
-      arg    <- newLocalVar (fsLit "xs") arg_ty
-
-      pdata_co <- mkBuiltinCo pdataTyCon
-      let co           = mkAppCo pdata_co
-                       $ mkSymCo
-                       $ mkUnbranchedAxInstCo Nominal repr_co ty_args []
-
-          scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)
-
-      (vars, result) <- to_sum r
-
-      return . Lam arg
-             $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
-               [(DataAlt pdata_dc, vars, mkCast result co)]
-  where
-    ty_args    = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty      = mkTyConApp vect_tc ty_args
-    [pdata_dc] = tyConDataCons pdata_tc
-
-    to_sum ss
-     = case ss of
-        EmptySum    -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid)
-        UnarySum r  -> to_con r
-        Sum{}
-         -> do  let psum_tc     =  repr_psum_tc ss
-                let [psum_con]  =  tyConDataCons psum_tc
-                (vars, exprs)   <- mapAndUnzipM to_con (repr_cons ss)
-                sel             <- newLocalVar (fsLit "sel") (repr_sel_ty ss)
-                return ( sel : concat vars
-                       , wrapFamInstBody psum_tc (repr_con_tys ss)
-                         $ mkConApp psum_con
-                         $ map Type (repr_con_tys ss) ++ (Var sel : exprs))
-
-    to_prod ss
-     = case ss of
-        EmptyProd    -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid)
-        UnaryProd r
-         -> do  pty  <- mkPDataType (compOrigType r)
-                var  <- newLocalVar (fsLit "x") pty
-                expr <- to_comp (Var var) r
-                return ([var], expr)
-        Prod{}
-         -> do  let [ptup_con]  = tyConDataCons (repr_ptup_tc ss)
-                ptys   <- mapM (mkPDataType . compOrigType) (repr_comps ss)
-                vars   <- newLocalVars (fsLit "x") ptys
-                exprs  <- zipWithM to_comp (map Var vars) (repr_comps ss)
-                return ( vars
-                       , wrapFamInstBody (repr_ptup_tc ss) (repr_comp_tys ss)
-                         $ mkConApp ptup_con
-                         $ map Type (repr_comp_tys ss) ++ exprs)
-
-    to_con (ConRepr _ r)    = to_prod r
-
-    to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDataWrap expr ty
-
-
--- buildFromArrPRepr ----------------------------------------------------------
-
--- |Build the 'fromArrPRepr' method for the PA class.
---
-buildFromArrPRepr :: PAInstanceBuilder
-buildFromArrPRepr vect_tc repr_co pdata_tc _ r
- = do arg_ty <- mkPDataType =<< mkPReprType el_ty
-      res_ty <- mkPDataType el_ty
-      arg    <- newLocalVar (fsLit "xs") arg_ty
-
-      pdata_co <- mkBuiltinCo pdataTyCon
-      let co           = mkAppCo pdata_co
-                       $ mkUnbranchedAxInstCo Nominal repr_co var_tys []
-
-      let scrut        = mkCast (Var arg) co
-
-      let mk_result args
-            = wrapFamInstBody pdata_tc var_tys
-            $ mkConApp pdata_con
-            $ map Type var_tys ++ args
-
-      (expr, _) <- fixV $ \ ~(_, args) ->
-                     from_sum res_ty (mk_result args) scrut r
-
-      return $ Lam arg expr
- where
-    var_tys     = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty       = mkTyConApp vect_tc var_tys
-    [pdata_con] = tyConDataCons pdata_tc
-
-    from_sum res_ty res expr ss
-     = case ss of
-        EmptySum    -> return (res, [])
-        UnarySum r  -> from_con res_ty res expr r
-        Sum {}
-         -> do  let psum_tc    =  repr_psum_tc ss
-                let [psum_con] =  tyConDataCons psum_tc
-                sel            <- newLocalVar (fsLit "sel") (repr_sel_ty ss)
-                ptys           <- mapM mkPDataType (repr_con_tys ss)
-                vars           <- newLocalVars (fsLit "xs") ptys
-                (res', args)   <- fold from_con res_ty res (map Var vars) (repr_cons ss)
-                let scrut      =  unwrapFamInstScrut psum_tc (repr_con_tys ss) expr
-                let body       =  mkWildCase scrut (exprType scrut) res_ty
-                                    [(DataAlt psum_con, sel : vars, res')]
-                return (body, Var sel : args)
-
-    from_prod res_ty res expr ss
-     = case ss of
-        EmptyProd   -> return (res, [])
-        UnaryProd r -> from_comp res_ty res expr r
-        Prod {}
-         -> do  let ptup_tc    =  repr_ptup_tc ss
-                let [ptup_con] =  tyConDataCons ptup_tc
-                ptys           <- mapM mkPDataType (repr_comp_tys ss)
-                vars           <- newLocalVars (fsLit "ys") ptys
-                (res', args)   <- fold from_comp res_ty res (map Var vars) (repr_comps ss)
-                let scrut      =  unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr
-                let body       =  mkWildCase scrut (exprType scrut) res_ty
-                                    [(DataAlt ptup_con, vars, res')]
-                return (body, args)
-
-    from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r
-
-    from_comp _ res expr (Keep _ _) = return (res, [expr])
-    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty
-                                         ; return (res, [expr'])
-                                         }
-
-    fold f res_ty res exprs rs
-      = foldrM f' (res, []) (zip exprs rs)
-      where
-        f' (expr, r) (res, args)
-         = do (res', args') <- f res_ty res expr r
-              return (res', args' ++ args)
-
-
--- buildToArrPReprs -----------------------------------------------------------
--- | Build the 'toArrPReprs' instance for the PA class.
---   This converts a PData of elements into the generic representation.
-buildToArrPReprs :: PAInstanceBuilder
-buildToArrPReprs vect_tc repr_co _ pdatas_tc r
- = do
-    -- The argument type of the instance.
-    --  eg: 'PDatas (Tree a b)'
-    arg_ty    <- mkPDatasType el_ty
-
-    -- The result type.
-    --  eg: 'PDatas (PRepr (Tree a b))'
-    res_ty    <- mkPDatasType =<< mkPReprType el_ty
-
-    -- Variable to bind the argument to the instance
-    -- eg: (xss :: PDatas (Tree a b))
-    varg      <- newLocalVar (fsLit "xss") arg_ty
-
-    -- Coercion to case between the (PRepr a) type and its instance.
-    pdatas_co <- mkBuiltinCo pdatasTyCon
-    let co           = mkAppCo pdatas_co
-                     $ mkSymCo
-                     $ mkUnbranchedAxInstCo Nominal repr_co ty_args []
-
-    let scrut        = unwrapFamInstScrut pdatas_tc ty_args (Var varg)
-    (vars, result)  <- to_sum r
-
-    return  $ Lam varg
-            $ mkWildCase scrut (mkTyConApp pdatas_tc ty_args) res_ty
-                    [(DataAlt pdatas_dc, vars, mkCast result co)]
-
- where
-    -- The element type of the argument.
-    --  eg: 'Tree a b'.
-    ty_args = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty   = mkTyConApp vect_tc ty_args
-
-    -- PDatas data constructor
-    [pdatas_dc] = tyConDataCons pdatas_tc
-
-    to_sum ss
-     = case ss of
-        -- We can't convert data types with no data.
-        -- See Note: [Empty PDatas].
-        EmptySum        -> do dflags <- getDynFlags
-                              return ([], errorEmptyPDatas dflags el_ty)
-        UnarySum r      -> do dflags <- getDynFlags
-                              to_con (errorEmptyPDatas dflags el_ty) r
-
-        Sum{}
-         -> do  let psums_tc     = repr_psums_tc ss
-                let [psums_con]  = tyConDataCons psums_tc
-                sels             <- newLocalVar (fsLit "sels") (repr_sels_ty ss)
-
-                -- Take the number of selectors to serve as the length of
-                -- and PDatas Void arrays in the product. See Note [Empty PDatas].
-                let xSums        =  App (repr_selsLength_v ss) (Var sels)
-
-                xSums_var <- newLocalVar (fsLit "xsum") intPrimTy
-
-                (vars, exprs)    <- mapAndUnzipM (to_con xSums_var) (repr_cons ss)
-                return ( sels : concat vars
-                       , wrapFamInstBody psums_tc (repr_con_tys ss)
-                         $ mkCoreLet (NonRec xSums_var xSums)
-                                 -- mkCoreLet ensures that the let/app invariant holds
-                         $ mkConApp psums_con
-                         $ map Type (repr_con_tys ss) ++ (Var sels : exprs))
-
-    to_prod xSums ss
-     = case ss of
-        EmptyProd
-         -> do  pvoids  <- builtin pvoidsVar
-                return ([], App (Var pvoids) (Var xSums) )
-
-        UnaryProd r
-         -> do  pty  <- mkPDatasType (compOrigType r)
-                var  <- newLocalVar (fsLit "x") pty
-                expr <- to_comp (Var var) r
-                return ([var], expr)
-
-        Prod{}
-         -> do  let [ptups_con]  = tyConDataCons (repr_ptups_tc ss)
-                ptys   <- mapM (mkPDatasType . compOrigType) (repr_comps ss)
-                vars   <- newLocalVars (fsLit "x") ptys
-                exprs  <- zipWithM to_comp (map Var vars) (repr_comps ss)
-                return ( vars
-                       , wrapFamInstBody (repr_ptups_tc ss) (repr_comp_tys ss)
-                         $ mkConApp ptups_con
-                         $ map Type (repr_comp_tys ss) ++ exprs)
-
-    to_con xSums (ConRepr _ r)
-        = to_prod xSums r
-
-    to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDatasWrap expr ty
-
-
--- buildFromArrPReprs ---------------------------------------------------------
-buildFromArrPReprs :: PAInstanceBuilder
-buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
- = do
-    -- The argument type of the instance.
-    --  eg: 'PDatas (PRepr (Tree a b))'
-    arg_ty      <- mkPDatasType =<< mkPReprType el_ty
-
-    -- The result type.
-    --  eg: 'PDatas (Tree a b)'
-    res_ty      <- mkPDatasType el_ty
-
-    -- Variable to bind the argument to the instance
-    -- eg: (xss :: PDatas (PRepr (Tree a b)))
-    varg        <- newLocalVar (fsLit "xss") arg_ty
-
-    -- Build the coercion between PRepr and the instance type
-    pdatas_co <- mkBuiltinCo pdatasTyCon
-    let co           = mkAppCo pdatas_co
-                     $ mkUnbranchedAxInstCo Nominal repr_co var_tys []
-
-    let scrut        = mkCast (Var varg) co
-
-    let mk_result args
-            = wrapFamInstBody pdatas_tc var_tys
-            $ mkConApp pdatas_con
-            $ map Type var_tys ++ args
-
-    (expr, _) <- fixV $ \ ~(_, args) ->
-                     from_sum res_ty (mk_result args) scrut r
-
-    return $ Lam varg expr
- where
-    -- The element type of the argument.
-    --  eg: 'Tree a b'.
-    ty_args      = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty        = mkTyConApp vect_tc ty_args
-
-    var_tys      = mkTyVarTys $ tyConTyVars vect_tc
-    [pdatas_con] = tyConDataCons pdatas_tc
-
-    from_sum res_ty res expr ss
-     = case ss of
-        -- We can't convert data types with no data.
-        -- See Note: [Empty PDatas].
-        EmptySum        -> do dflags <- getDynFlags
-                              return (res, errorEmptyPDatas dflags el_ty)
-        UnarySum r      -> from_con res_ty res expr r
-
-        Sum {}
-         -> do  let psums_tc    =  repr_psums_tc ss
-                let [psums_con] =  tyConDataCons psums_tc
-                sel             <- newLocalVar (fsLit "sels") (repr_sels_ty ss)
-                ptys            <- mapM mkPDatasType (repr_con_tys ss)
-                vars            <- newLocalVars (fsLit "xs") ptys
-                (res', args)    <- fold from_con res_ty res (map Var vars) (repr_cons ss)
-                let scrut       =  unwrapFamInstScrut psums_tc (repr_con_tys ss) expr
-                let body        =  mkWildCase scrut (exprType scrut) res_ty
-                                    [(DataAlt psums_con, sel : vars, res')]
-                return (body, Var sel : args)
-
-    from_prod res_ty res expr ss
-     = case ss of
-        EmptyProd   -> return (res, [])
-        UnaryProd r -> from_comp res_ty res expr r
-        Prod {}
-         -> do  let ptups_tc    =  repr_ptups_tc ss
-                let [ptups_con] =  tyConDataCons ptups_tc
-                ptys            <- mapM mkPDatasType (repr_comp_tys ss)
-                vars            <- newLocalVars (fsLit "ys") ptys
-                (res', args)    <- fold from_comp res_ty res (map Var vars) (repr_comps ss)
-                let scrut       =  unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr
-                let body        =  mkWildCase scrut (exprType scrut) res_ty
-                                    [(DataAlt ptups_con, vars, res')]
-                return (body, args)
-
-    from_con res_ty res expr (ConRepr _ r)
-        = from_prod res_ty res expr r
-
-    from_comp _ res expr (Keep _ _) = return (res, [expr])
-    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty
-                                         ; return (res, [expr'])
-                                         }
-
-    fold f res_ty res exprs rs
-      = foldrM f' (res, []) (zip exprs rs)
-      where
-        f' (expr, r) (res, args)
-         = do (res', args') <- f res_ty res expr r
-              return (res', args' ++ args)
-
-
--- Notes ----------------------------------------------------------------------
-{-
-Note [Empty PDatas]
-~~~~~~~~~~~~~~~~~~~
-We don't support "empty" data types like the following:
-
-  data Empty0
-  data Empty1 = MkEmpty1
-  data Empty2 = MkEmpty2 Empty0
-  ...
-
-There is no parallel data associcated with these types, so there is no where
-to store the length of the PDatas array with our standard representation.
-
-Enumerations like the following are ok:
-  data Bool = True | False
-
-The native and generic representations are:
-  type instance (PDatas Bool)        = VPDs:Bool Sels2
-  type instance (PDatas (Repr Bool)) = PSum2s Sels2 (PDatas Void) (PDatas Void)
-
-To take the length of a (PDatas Bool) we take the length of the contained Sels2.
-When converting a (PDatas Bool) to a (PDatas (Repr Bool)) we use this length to
-initialise the two (PDatas Void) arrays.
-
-However, with this:
-  data Empty1 = MkEmpty1
-
-The native and generic representations would be:
-  type instance (PDatas Empty1)        = VPDs:Empty1
-  type instance (PDatas (Repr Empty1)) = PVoids Int
-
-The 'Int' argument of PVoids is supposed to store the length of the PDatas
-array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we
-need to come up with a value for it, but there isn't one.
-
-To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's
-too much hassle and there's no point running a parallel computation on no
-data anyway.
--}
-errorEmptyPDatas :: DynFlags -> Type -> a
-errorEmptyPDatas dflags tc
-    = cantVectorise dflags "Vectorise.PAMethods"
-    $ vcat  [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc)
-            , text "Data types to be vectorised must contain at least one constructor"
-            , text "with at least one field." ]
diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs
deleted file mode 100644
index 4560c83e8b..0000000000
--- a/compiler/vectorise/Vectorise/Generic/PData.hs
+++ /dev/null
@@ -1,168 +0,0 @@
-
--- | Build instance tycons for the PData and PDatas type families.
---
---   TODO: the PData and PDatas cases are very similar.
---   We should be able to factor out the common parts.
-module Vectorise.Generic.PData
-  ( buildPDataTyCon
-  , buildPDatasTyCon )
-where
-
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Generic.Description
-import Vectorise.Utils
-import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
-
-import BasicTypes ( SourceText(..) )
-import BuildTyCl
-import DataCon
-import TyCon
-import Type
-import FamInst
-import FamInstEnv
-import TcMType
-import Name
-import Util
-import MonadUtils
-import Control.Monad
-
-
--- buildPDataTyCon ------------------------------------------------------------
--- | Build the PData instance tycon for a given type constructor.
-buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDataTyCon orig_tc vect_tc repr
- = fixV $ \fam_inst ->
-   do let repr_tc = dataFamInstRepTyCon fam_inst
-      name' <- mkLocalisedName mkPDataTyConOcc orig_name
-      rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
-      pdata <- builtin pdataTyCon
-      buildDataFamInst name' pdata vect_tc rhs
- where
-    orig_name = tyConName orig_tc
-
-buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
-buildDataFamInst name' fam_tc vect_tc rhs
- = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
-
-      ; (_, tyvars') <- liftDs $ freshenTyVarBndrs tyvars
-      ; let ax       = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty
-            tys'     = mkTyVarTys tyvars'
-            rep_ty   = mkTyConApp rep_tc tys'
-            pat_tys  = [mkTyConApp vect_tc tys']
-            rep_tc   = mkAlgTyCon name'
-                           (mkTyConBindersPreferAnon tyvars' liftedTypeKind)
-                           liftedTypeKind
-                           (map (const Nominal) tyvars')
-                           Nothing
-                           []          -- no stupid theta
-                           rhs
-                           (DataFamInstTyCon ax fam_tc pat_tys)
-                           False       -- not GADT syntax
-      ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax }
- where
-    tyvars    = tyConTyVars vect_tc
-
-buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
-buildPDataTyConRhs orig_name vect_tc repr_tc repr
- = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
-      return $ DataTyCon { data_cons = [data_con], is_enum = False }
-
-
-buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
-buildPDataDataCon orig_name vect_tc repr_tc repr
- = do let tvs   = tyConTyVars vect_tc
-      dc_name   <- mkLocalisedName mkPDataDataConOcc orig_name
-      comp_tys  <- mkSumTys repr_sel_ty mkPDataType repr
-      fam_envs  <- readGEnv global_fam_inst_env
-      rep_nm    <- liftDs $ newTyConRepName dc_name
-      liftDs $ buildDataCon fam_envs dc_name
-                            False                  -- not infix
-                            rep_nm
-                            (map (const no_bang) comp_tys)
-                            (Just $ map (const HsLazy) comp_tys)
-                            []                     -- no field labels
-                            (mkTyVarBinders Specified tvs)
-                            []                     -- no existentials
-                            []                     -- no eq spec
-                            []                     -- no context
-                            comp_tys
-                            (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
-                            repr_tc
-  where
-    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
-
-
--- buildPDatasTyCon -----------------------------------------------------------
--- | Build the PDatas instance tycon for a given type constructor.
-buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
-buildPDatasTyCon orig_tc vect_tc repr
- = fixV $ \fam_inst ->
-   do let repr_tc = dataFamInstRepTyCon fam_inst
-      name'       <- mkLocalisedName mkPDatasTyConOcc orig_name
-      rhs         <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
-      pdatas     <- builtin pdatasTyCon
-      buildDataFamInst name' pdatas vect_tc rhs
- where
-    orig_name = tyConName orig_tc
-
-buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
-buildPDatasTyConRhs orig_name vect_tc repr_tc repr
- = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr
-      return $ DataTyCon { data_cons = [data_con], is_enum = False }
-
-
-buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
-buildPDatasDataCon orig_name vect_tc repr_tc repr
- = do let tvs   = tyConTyVars vect_tc
-      dc_name        <- mkLocalisedName mkPDatasDataConOcc orig_name
-
-      comp_tys  <- mkSumTys repr_sels_ty mkPDatasType repr
-      fam_envs <- readGEnv global_fam_inst_env
-      rep_nm   <- liftDs $ newTyConRepName dc_name
-      liftDs $ buildDataCon fam_envs dc_name
-                            False                  -- not infix
-                            rep_nm
-                            (map (const no_bang) comp_tys)
-                            (Just $ map (const HsLazy) comp_tys)
-                            []                     -- no field labels
-                            (mkTyVarBinders Specified tvs)
-                            []                     -- no existentials
-                            []                     -- no eq spec
-                            []                     -- no context
-                            comp_tys
-                            (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
-                            repr_tc
-  where
-     no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
-
-
--- Utils ----------------------------------------------------------------------
--- | Flatten a SumRepr into a list of data constructor types.
-mkSumTys
-        :: (SumRepr -> Type)
-        -> (Type -> VM Type)
-        -> SumRepr
-        -> VM [Type]
-
-mkSumTys repr_selX_ty mkTc repr
- = sum_tys repr
- where
-    sum_tys EmptySum      = return []
-    sum_tys (UnarySum r)  = con_tys r
-    sum_tys d@(Sum { repr_cons   = cons })
-      = liftM (repr_selX_ty d :) (concatMapM con_tys cons)
-
-    con_tys (ConRepr _ r)  = prod_tys r
-
-    prod_tys EmptyProd     = return []
-    prod_tys (UnaryProd r) = liftM singleton (comp_ty r)
-    prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps
-
-    comp_ty r = mkTc (compOrigType r)
-
-{-
-mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
-mk_fam_inst fam_tc arg_tc
-  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
--}
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
deleted file mode 100644
index ac8b87a0dc..0000000000
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ /dev/null
@@ -1,194 +0,0 @@
-module Vectorise.Monad (
-  module Vectorise.Monad.Base,
-  module Vectorise.Monad.Naming,
-  module Vectorise.Monad.Local,
-  module Vectorise.Monad.Global,
-  module Vectorise.Monad.InstEnv,
-  initV,
-
-  -- * Builtins
-  liftBuiltinDs,
-  builtin,
-  builtins,
-
-  -- * Variables
-  lookupVar,
-  lookupVar_maybe,
-  addGlobalParallelVar,
-  addGlobalParallelTyCon,
-) where
-
-import Vectorise.Monad.Base
-import Vectorise.Monad.Naming
-import Vectorise.Monad.Local
-import Vectorise.Monad.Global
-import Vectorise.Monad.InstEnv
-import Vectorise.Builtins
-import Vectorise.Env
-
-import CoreSyn
-import TcRnMonad
-import DsMonad
-import HscTypes hiding ( MonadThings(..) )
-import DynFlags
-import InstEnv
-import Class
-import TyCon
-import NameSet
-import VarSet
-import VarEnv
-import Var
-import Id
-import Name
-import ErrUtils
-import Outputable
-import Module
-
-import Control.Monad (join)
-
--- |Run a vectorisation computation.
---
-initV :: HscEnv
-      -> ModGuts
-      -> VectInfo
-      -> VM a
-      -> IO (Maybe (VectInfo, a))
-initV hsc_env guts info thing_inside
-  = do { dumpIfVtTrace "Incoming VectInfo" (ppr info)
-
-       ; (_, res) <- initDsWithModGuts hsc_env guts go
-       ; case join res of
-           Nothing
-             -> dumpIfVtTrace "Vectorisation FAILED!" empty
-           Just (info', _)
-             -> dumpIfVtTrace "Outgoing VectInfo" (ppr info')
-
-       ; return $ join res
-       }
-  where
-    dflags = hsc_dflags hsc_env
-
-    dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace
-
-    bindsToIds (NonRec v _)   = [v]
-    bindsToIds (Rec    binds) = map fst binds
-
-    ids = concatMap bindsToIds (mg_binds guts)
-
-    go
-      = do {   -- set up tables of builtin entities
-           ; builtins        <- initBuiltins
-           ; builtin_vars    <- initBuiltinVars builtins
-
-               -- set up class and type family envrionments
-           ; eps <- liftIO $ hscEPS hsc_env
-           ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
-                 instEnvs    = InstEnvs (eps_inst_env     eps)
-                                        (mg_inst_env     guts)
-                                        (mkModuleSet (dep_orphs (mg_deps guts)))
-                 builtin_pas = initClassDicts instEnvs (paClass builtins)  -- grab all 'PA' and..
-                 builtin_prs = initClassDicts instEnvs (prClass builtins)  -- ..'PR' class instances
-
-               -- construct the initial global environment
-           ; let genv = extendImportedVarsEnv builtin_vars
-                        . setPAFunsEnv        builtin_pas
-                        . setPRFunsEnv        builtin_prs
-                        $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags)
-                                        info (mg_vect_decls guts) instEnvs famInstEnvs
-
-               -- perform vectorisation
-           ; r <- runVM thing_inside builtins genv emptyLocalEnv
-           ; case r of
-               Yes genv _ x -> return $ Just (new_info genv, x)
-               No reason    -> do { unqual <- mkPrintUnqualifiedDs
-                                  ; liftIO $
-                                      printOutputForUser dflags unqual $
-                                        mkDumpDoc "Warning: vectorisation failure:" reason
-                                  ; return Nothing
-                                  }
-           }
-
-    new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info
-
-    -- For a given DPH class, produce a mapping from type constructor (in head position) to the
-    -- instance dfun for that type constructor and class.  (DPH class instances cannot overlap in
-    -- head constructors.)
-    --
-    initClassDicts :: InstEnvs -> Class -> [(Name, Var)]
-    initClassDicts insts cls = map find $ classInstances insts cls
-      where
-        find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
-               | otherwise                       = pprPanic invalidInstance (ppr i)
-
-    invalidInstance = "Invalid DPH instance (overlapping in head constructor)"
-
--- Builtins -------------------------------------------------------------------
-
--- |Lift a desugaring computation using the `Builtins` into the vectorisation monad.
---
-liftBuiltinDs :: (Builtins -> DsM a) -> VM a
-liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
-
--- |Project something from the set of builtins.
---
-builtin :: (Builtins -> a) -> VM a
-builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
-
--- |Lift a function using the `Builtins` into the vectorisation monad.
---
-builtins :: (a -> Builtins -> b) -> VM (a -> b)
-builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
-
-
--- Var ------------------------------------------------------------------------
-
--- |Lookup the vectorised, and if local, also the lifted version of a variable.
---
--- * If it's in the global environment we get the vectorised version.
--- * If it's in the local environment we get both the vectorised and lifted version.
---
-lookupVar :: Var -> VM (Scope Var (Var, Var))
-lookupVar v
-  = do { mb_res <- lookupVar_maybe v
-       ; case mb_res of
-           Just x  -> return x
-           Nothing ->
-               do dflags <- getDynFlags
-                  dumpVar dflags v
-       }
-
-lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var)))
-lookupVar_maybe v
- = do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
-      ; case r of
-          Just e  -> return $ Just (Local e)
-          Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
-      }
-
-dumpVar :: DynFlags -> Var -> a
-dumpVar dflags var
-  | Just _    <- isClassOpId_maybe var
-  = cantVectorise dflags "ClassOpId not vectorised:" (ppr var)
-  | otherwise
-  = cantVectorise dflags "Variable not vectorised:" (ppr var)
-
-
--- Global parallel entities ----------------------------------------------------
-
--- |Mark the given variable as parallel — i.e., executing the associated code might involve
--- parallel array computations.
---
-addGlobalParallelVar :: Var -> VM ()
-addGlobalParallelVar var
-  = do { traceVt "addGlobalParallelVar" (ppr var)
-       ; updGEnv $ \env -> env{global_parallel_vars = extendDVarSet (global_parallel_vars env) var}
-       }
-
--- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays.
---
-addGlobalParallelTyCon :: TyCon -> VM ()
-addGlobalParallelTyCon tycon
-  = do { traceVt "addGlobalParallelTyCon" (ppr tycon)
-       ; updGEnv $ \env ->
-           env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)}
-       }
diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
deleted file mode 100644
index a612a9c1cc..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ /dev/null
@@ -1,243 +0,0 @@
--- |The Vectorisation monad.
-
-module Vectorise.Monad.Base (
-  -- * The Vectorisation Monad
-  VResult(..),
-  VM(..),
-
-  -- * Lifting
-  liftDs,
-
-  -- * Error Handling
-  cantVectorise,
-  maybeCantVectorise,
-  maybeCantVectoriseM,
-
-  -- * Debugging
-  emitVt, traceVt, dumpOptVt, dumpVt,
-
-  -- * Control
-  noV, traceNoV,
-  ensureV, traceEnsureV,
-  onlyIfV,
-  tryV, tryErrV,
-  maybeV,  traceMaybeV,
-  orElseV, orElseErrV,
-  fixV,
-) where
-
-import Vectorise.Builtins
-import Vectorise.Env
-
-import DsMonad
-import TcRnMonad
-import ErrUtils
-import Outputable
-import DynFlags
-
-import Control.Monad
-
-
--- The Vectorisation Monad ----------------------------------------------------
-
--- |Vectorisation can either succeed with new envionment and a value, or return with failure
--- (including a description of the reason for failure).
---
-data VResult a
-  = Yes GlobalEnv LocalEnv a
-  | No  SDoc
-
-newtype VM a
-  = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
-
-instance Monad VM where
-  VM p >>= f = VM $ \bi genv lenv -> do
-                                       r <- p bi genv lenv
-                                       case r of
-                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
-                                         No reason         -> return $ No reason
-
-instance Applicative VM where
-  pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)
-  (<*>) = ap
-
-instance Functor VM where
-  fmap = liftM
-
-instance MonadIO VM where
-  liftIO = liftDs . liftIO
-
-instance HasDynFlags VM where
-    getDynFlags = liftDs getDynFlags
-
--- Lifting --------------------------------------------------------------------
-
--- |Lift a desugaring computation into the vectorisation monad.
---
-liftDs :: DsM a -> VM a
-liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
-
-
--- Error Handling -------------------------------------------------------------
-
--- |Throw a `pgmError` saying we can't vectorise something.
---
-cantVectorise :: DynFlags -> String -> SDoc -> a
-cantVectorise dflags s d = pgmError
-                  . showSDoc dflags
-                  $ vcat [text "*** Vectorisation error ***",
-                          nest 4 $ sep [text s, nest 4 d]]
-
--- |Like `fromJust`, but `pgmError` on Nothing.
---
-maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a
-maybeCantVectorise dflags s d Nothing  = cantVectorise dflags s d
-maybeCantVectorise _ _ _ (Just x) = x
-
--- |Like `maybeCantVectorise` but in a `Monad`.
---
-maybeCantVectoriseM :: (Monad m, HasDynFlags m)
-                    => String -> SDoc -> m (Maybe a) -> m a
-maybeCantVectoriseM s d p
-  = do
-      r <- p
-      case r of
-        Just x  -> return x
-        Nothing ->
-            do dflags <- getDynFlags
-               cantVectorise dflags s d
-
-
--- Debugging ------------------------------------------------------------------
-
--- |Output a trace message if -ddump-vt-trace is active.
---
-emitVt :: String -> SDoc -> VM ()
-emitVt herald doc
-  = liftDs $ do
-      dflags <- getDynFlags
-      liftIO . printOutputForUser dflags alwaysQualify $
-        hang (text herald) 2 doc
-
--- |Output a trace message if -ddump-vt-trace is active.
---
-traceVt :: String -> SDoc -> VM ()
-traceVt herald doc
-  = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc
-
--- |Dump the given program conditionally.
---
-dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()
-dumpOptVt flag header doc
-  = do { b <- liftDs $ doptM flag
-       ; if b
-         then dumpVt header doc
-         else return ()
-       }
-
--- |Dump the given program unconditionally.
---
-dumpVt :: String -> SDoc -> VM ()
-dumpVt header doc
-  = do { unqual <- liftDs mkPrintUnqualifiedDs
-       ; dflags <- liftDs getDynFlags
-       ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc)
-       }
-
-
--- Control --------------------------------------------------------------------
-
--- |Return some result saying we've failed.
---
-noV :: SDoc -> VM a
-noV reason = VM $ \_ _ _ -> return $ No reason
-
--- |Like `traceNoV` but also emit some trace message to stderr.
---
-traceNoV :: String -> SDoc -> VM a
-traceNoV s d = pprTrace s d $ noV d
-
--- |If `True` then carry on, otherwise fail.
---
-ensureV :: SDoc -> Bool -> VM ()
-ensureV reason  False = noV reason
-ensureV _reason True  = return ()
-
--- |Like `ensureV` but if we fail then emit some trace message to stderr.
---
-traceEnsureV :: String -> SDoc -> Bool -> VM ()
-traceEnsureV s d False = traceNoV s d
-traceEnsureV _ _ True  = return ()
-
--- |If `True` then return the first argument, otherwise fail.
---
-onlyIfV :: SDoc -> Bool -> VM a -> VM a
-onlyIfV reason b p = ensureV reason b >> p
-
--- |Try some vectorisation computaton.
---
--- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a
--- failure message.
---
-tryErrV :: VM a -> VM (Maybe a)
-tryErrV (VM p) = VM $ \bi genv lenv ->
-  do
-    r <- p bi genv lenv
-    case r of
-      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
-      No reason         -> do { unqual <- mkPrintUnqualifiedDs
-                              ; dflags <- getDynFlags
-                              ; liftIO $
-                                  printInfoForUser dflags unqual $
-                                    text "Warning: vectorisation failure:" <+> reason
-                              ; return (Yes genv  lenv  Nothing)
-                              }
-
--- |Try some vectorisation computaton.
---
--- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a
--- failure message.
---
-tryV :: VM a -> VM (Maybe a)
-tryV (VM p) = VM $ \bi genv lenv ->
-  do
-    r <- p bi genv lenv
-    case r of
-      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
-      No _reason        -> return (Yes genv  lenv  Nothing)
-
--- |If `Just` then return the value, otherwise fail.
---
-maybeV :: SDoc -> VM (Maybe a) -> VM a
-maybeV reason p = maybe (noV reason) return =<< p
-
--- |Like `maybeV` but emit a message to stderr if we fail.
---
-traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
-traceMaybeV s d p = maybe (traceNoV s d) return =<< p
-
--- |Try the first computation,
---
---   * if it succeeds then take the returned value,
---   * if it fails then run the second computation instead while emitting a failure message.
---
-orElseErrV :: VM a -> VM a -> VM a
-orElseErrV p q = maybe q return =<< tryErrV p
-
--- |Try the first computation,
---
---   * if it succeeds then take the returned value,
---   * if it fails then run the second computation instead without emitting a failure message.
---
-orElseV :: VM a -> VM a -> VM a
-orElseV p q = maybe q return =<< tryV p
-
--- |Fixpoint in the vectorisation monad.
---
-fixV :: (a -> VM a) -> VM a
-fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
-  where
-    -- NOTE: It is essential that we are lazy in r above so do not replace
-    --       calls to this function by an explicit case.
-    unYes (Yes _ _ x) = x
-    unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
deleted file mode 100644
index cd642f37b6..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ /dev/null
@@ -1,237 +0,0 @@
--- Operations on the global state of the vectorisation monad.
-
-module Vectorise.Monad.Global (
-  readGEnv,
-  setGEnv,
-  updGEnv,
-
-  -- * Configuration
-  isVectAvoidanceAggressive,
-
-  -- * Vars
-  defGlobalVar, undefGlobalVar,
-
-  -- * Vectorisation declarations
-  lookupVectDecl,
-
-  -- * Scalars
-  globalParallelVars, globalParallelTyCons,
-
-  -- * TyCons
-  lookupTyCon,
-  defTyConName, defTyCon, globalVectTyCons,
-
-  -- * Datacons
-  lookupDataCon,
-  defDataCon,
-
-  -- * PA Dictionaries
-  lookupTyConPA,
-  defTyConPAs,
-
-  -- * PR Dictionaries
-  lookupTyConPR
-) where
-
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import CoreSyn
-import Type
-import TyCon
-import DataCon
-import DynFlags
-import NameEnv
-import NameSet
-import Name
-import VarEnv
-import VarSet
-import Var as Var
-import Outputable
-
-
--- Global Environment ---------------------------------------------------------
-
--- |Project something from the global environment.
---
-readGEnv :: (GlobalEnv -> a) -> VM a
-readGEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
-
--- |Set the value of the global environment.
---
-setGEnv :: GlobalEnv -> VM ()
-setGEnv genv  = VM $ \_ _ lenv -> return (Yes genv lenv ())
-
--- |Update the global environment using the provided function.
---
-updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
-updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
-
-
--- Configuration --------------------------------------------------------------
-
--- |Should we avoid as much vectorisation as possible?
---
--- Set by '-f[no]-vectorisation-avoidance'
---
-isVectAvoidanceAggressive :: VM Bool
-isVectAvoidanceAggressive = readGEnv global_vect_avoid
-
-
--- Vars -----------------------------------------------------------------------
-
--- |Add a mapping between a global var and its vectorised version to the state.
---
-defGlobalVar :: Var -> Var -> VM ()
-defGlobalVar v v'
-  = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v')
-
-           -- check for duplicate vectorisation
-       ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
-       ; case currentDef of
-           Just old_v' ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Variable is already vectorised:" $
-                            ppr v <+> moduleOf v old_v'
-           Nothing     -> return ()
-
-       ; updGEnv  $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
-       }
-  where
-    moduleOf var var' | var == var'
-                      = text "vectorises to itself"
-                      | Just mod <- nameModule_maybe (Var.varName var')
-                      = text "in module" <+> ppr mod
-                      | otherwise
-                      = text "in the current module"
-
--- |Remove the mapping of a variable in the vectorisation map.
---
-undefGlobalVar :: Var -> VM ()
-undefGlobalVar v
-  = do
-    { traceVt "REMOVING global var mapping:" (ppr v)
-    ; updGEnv  $ \env -> env { global_vars = delVarEnv (global_vars env) v }
-    }
-
-
--- Vectorisation declarations -------------------------------------------------
-
--- |Check whether a variable has a vectorisation declaration.
---
--- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration.
--- The second component contains the given type and expression in case of a 'VECTORISE' declaration.
---
-lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr))
-lookupVectDecl var
-  = readGEnv $ \env ->
-      case lookupVarEnv (global_vect_decls env) var of
-        Nothing -> (False, Nothing)
-        Just Nothing  -> (True, Nothing)
-        Just vectDecl -> (False, vectDecl)
-
-
--- Parallel entities -----------------------------------------------------------
-
--- |Get the set of global parallel variables.
---
-globalParallelVars :: VM DVarSet
-globalParallelVars = readGEnv global_parallel_vars
-
--- |Get the set of all parallel type constructors (those that may embed parallelism) including both
--- both those parallel type constructors declared in an imported module and those declared in the
--- current module.
---
-globalParallelTyCons :: VM NameSet
-globalParallelTyCons = readGEnv global_parallel_tycons
-
-
--- TyCons ---------------------------------------------------------------------
-
--- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment
--- contains a vectorised version if the original `TyCon` embeds any parallel arrays.
---
-lookupTyCon :: TyCon -> VM (Maybe TyCon)
-lookupTyCon tc
-  = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-
--- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
---
--- The second argument is only to enable tracing for (mutually) recursively defined type
--- constructors, where we /must not/ pull at the vectorised type constructors (because that would
--- pull too early at the recursive knot).
---
-defTyConName :: TyCon -> Name -> TyCon -> VM ()
-defTyConName tc nameOfTc' tc'
-  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc')
-
-           -- check for duplicate vectorisation
-       ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-       ; case currentDef of
-           Just old_tc' ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Type constructor or class is already vectorised:" $
-                            ppr tc <+> moduleOf tc old_tc'
-           Nothing     -> return ()
-
-       ; updGEnv $ \env ->
-           env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
-       }
-  where
-    moduleOf tc tc' | tc == tc'
-                    = text "vectorises to itself"
-                    | Just mod <- nameModule_maybe (tyConName tc')
-                    = text "in module" <+> ppr mod
-                    | otherwise
-                    = text "in the current module"
-
--- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
---
-defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc' = defTyConName tc (tyConName tc') tc'
-
--- |Get the set of all vectorised type constructors.
---
-globalVectTyCons :: VM (NameEnv TyCon)
-globalVectTyCons = readGEnv global_tycons
-
-
--- DataCons -------------------------------------------------------------------
-
--- |Lookup the vectorised version of a `DataCon` from the global environment.
---
-lookupDataCon :: DataCon -> VM (Maybe DataCon)
-lookupDataCon dc
-  | isTupleTyCon (dataConTyCon dc)
-  = return (Just dc)
-  | otherwise
-  = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
-
--- |Add the mapping between plain and vectorised `DataCon`s to the global environment.
---
-defDataCon :: DataCon -> DataCon -> VM ()
-defDataCon dc dc' = updGEnv $ \env ->
-  env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
-
-
--- 'PA' dictionaries ------------------------------------------------------------
-
--- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment.
---
-lookupTyConPA :: TyCon -> VM (Maybe Var)
-lookupTyConPA tc
-  = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
-
--- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global
--- environment.
---
-defTyConPAs :: [(TyCon, Var)] -> VM ()
-defTyConPAs ps = updGEnv $ \env ->
-  env { global_pa_funs = extendNameEnvList (global_pa_funs env)
-                                           [(tyConName tc, pa) | (tc, pa) <- ps] }
-
-
--- PR Dictionaries ------------------------------------------------------------
-
-lookupTyConPR :: TyCon -> VM (Maybe Var)
-lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
deleted file mode 100644
index 64b7441235..0000000000
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Vectorise.Monad.InstEnv
-  ( existsInst
-  , lookupInst
-  , lookupFamInst
-  )
-where
-
-import Vectorise.Monad.Global
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import DynFlags
-import FamInstEnv
-import InstEnv
-import Class
-import Type
-import TyCon
-import Outputable
-import Util
-
-
-#include "HsVersions.h"
-
-
--- Check whether a unique class instance for a given class and type arguments exists.
---
-existsInst :: Class -> [Type] -> VM Bool
-existsInst cls tys
-  = do { instEnv <- readGEnv global_inst_env
-       ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv cls tys)
-       }
-
--- Look up the dfun of a class instance.
---
--- The match must be unique —i.e., match exactly one instance— but the
--- type arguments used for matching may be more specific than those of
--- the class instance declaration.  The found class instances must not have
--- any type variables in the instance context that do not appear in the
--- instances head (i.e., no flexi vars); for details for what this means,
--- see the docs at InstEnv.lookupInstEnv.
---
-lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
-lookupInst cls tys
-  = do { instEnv <- readGEnv global_inst_env
-       ; case lookupUniqueInstEnv instEnv cls tys of
-           Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys)
-           Left  err              ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err
-       }
-
--- Look up a family instance.
---
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the family instance declaration.
---
--- Return the family instance and its type instance.  For example, if we have
---
---  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
---
--- then we have a coercion (ie, type instance of family instance coercion)
---
---  :Co:R42T Int :: T [Int] ~ :R42T Int
---
--- which implies that :R42T was declared as 'data instance T [a]'.
---
-lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch
-lookupFamInst tycon tys
-  = ASSERT( isOpenFamilyTyCon tycon )
-    do { instEnv <- readGEnv global_fam_inst_env
-       ; case lookupFamInstEnv instEnv tycon tys of
-           [match] -> return match
-           _other                ->
-             do dflags <- getDynFlags
-                cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: "
-                           (ppr $ mkTyConApp tycon tys)
-       }
diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs
deleted file mode 100644
index 61f55ccd43..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Local.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-module Vectorise.Monad.Local
-  ( readLEnv
-  , setLEnv
-  , updLEnv
-  , localV
-  , closedV
-  , getBindName
-  , inBind
-  , lookupTyVarPA
-  , defLocalTyVar
-  , defLocalTyVarWithPA
-  , localTyVars
-  )
-where
-
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import CoreSyn
-import Name
-import VarEnv
-import Var
-import FastString
-
--- Local Environment ----------------------------------------------------------
-
--- |Project something from the local environment.
---
-readLEnv :: (LocalEnv -> a) -> VM a
-readLEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
-
--- |Set the local environment.
---
-setLEnv :: LocalEnv -> VM ()
-setLEnv lenv  = VM $ \_ genv _ -> return (Yes genv lenv ())
-
--- |Update the environment using the provided function.
---
-updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
-updLEnv f  = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
-
--- |Perform a computation in its own local environment.
--- This does not alter the environment of the current state.
---
-localV :: VM a -> VM a
-localV p
-  = do
-    { env <- readLEnv id
-    ; x   <- p
-    ; setLEnv env
-    ; return x
-    }
-
--- |Perform a computation in an empty local environment.
---
-closedV :: VM a -> VM a
-closedV p
-  = do
-    { env <- readLEnv id
-    ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
-    ; x   <- p
-    ; setLEnv env
-    ; return x
-    }
-
--- |Get the name of the local binding currently being vectorised.
---
-getBindName :: VM FastString
-getBindName = readLEnv local_bind_name
-
--- |Run a vectorisation computation in a local environment,
--- with this id set as the current binding.
---
-inBind :: Id -> VM a -> VM a
-inBind id p
-  = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
-       p
-
--- |Lookup a PA tyvars from the local environment.
-lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
-lookupTyVarPA tv
-   = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
-
--- |Add a tyvar to the local environment.
-defLocalTyVar :: TyVar -> VM ()
-defLocalTyVar tv = updLEnv $ \env ->
-  env { local_tyvars   = tv : local_tyvars env
-      , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
-      }
-
--- |Add mapping between a tyvar and pa dictionary to the local environment.
-defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
-defLocalTyVarWithPA tv pa = updLEnv $ \env ->
-  env { local_tyvars   = tv : local_tyvars env
-      , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
-      }
-
--- |Get the set of tyvars from the local environment.
-localTyVars :: VM [TyVar]
-localTyVars = readLEnv (reverse . local_tyvars)
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
deleted file mode 100644
index 0b46416ddb..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ /dev/null
@@ -1,130 +0,0 @@
--- |Computations in the vectorisation monad concerned with naming and fresh variable generation.
-
-module Vectorise.Monad.Naming
-  ( mkLocalisedName
-  , mkDerivedName
-  , mkVectId
-  , cloneVar
-  , newExportedVar
-  , newLocalVar
-  , newLocalVars
-  , newDummyVar
-  , newTyVar
-  , newCoVar
-  )
-where
-
-import Vectorise.Monad.Base
-
-import DsMonad
-import TcType
-import Type
-import Var
-import Module
-import Name
-import SrcLoc
-import MkId
-import Id
-import IdInfo( IdDetails(VanillaId) )
-import FastString
-
-import Control.Monad
-
-
--- Naming ---------------------------------------------------------------------
-
--- |Create a localised variant of a name, using the provided function to transform its `OccName`.
---
--- If the name external, encode the original name's module into the new 'OccName'.  The result is
--- always an internal system name.
---
-mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
-mkLocalisedName mk_occ name
-  = do { mod <- liftDs getModule
-       ; u   <- liftDs newUnique
-       ; let occ_name = mkLocalisedOccName mod mk_occ name
-
-             new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
-                      | otherwise           = mkSystemName   u     occ_name
-
-       ; return new_name }
-
-mkDerivedName :: (OccName -> OccName) -> Name -> VM Name
--- Similar to mkLocalisedName, but assumes the
--- incoming name is from this module.
--- Works on External names only
-mkDerivedName mk_occ name
-  = do { u   <- liftDs newUnique
-       ; return (mkExternalName u (nameModule name)
-                                  (mk_occ (nameOccName name))
-                                  (nameSrcSpan name)) }
-
--- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that
--- vectorised dfun ids must be dfuns again.
---
--- Force the new name to be a system name and, if the original was an external name, disambiguate
--- the new name with the module name of the original.
---
-mkVectId :: Id -> Type -> VM Id
-mkVectId id ty
-  = do { name <- mkLocalisedName mkVectOcc (getName id)
-       ; let id' | isDFunId id     = MkId.mkDictFunId name tvs theta cls tys
-                 | isExportedId id = Id.mkExportedLocalId VanillaId name ty
-                 | otherwise       = Id.mkLocalIdOrCoVar name ty
-       ; return id'
-       }
-  where
-    -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys
-    -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary
-    --     functions are always fully applied.
-    (tvs, theta, pty) = tcSplitSigmaTy  ty
-    (cls, tys)        = tcSplitDFunHead pty
-
--- |Make a fresh instance of this var, with a new unique.
---
-cloneVar :: Var -> VM Var
-cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
-
--- |Make a fresh exported variable with the given type.
---
-newExportedVar :: OccName -> Type -> VM Var
-newExportedVar occ_name ty
- = do mod <- liftDs getModule
-      u   <- liftDs newUnique
-
-      let name = mkExternalName u mod occ_name noSrcSpan
-
-      return $ Id.mkExportedLocalId VanillaId name ty
-
--- |Make a fresh local variable with the given type.
--- The variable's name is formed using the given string as the prefix.
---
-newLocalVar :: FastString -> Type -> VM Var
-newLocalVar fs ty
- = do u <- liftDs newUnique
-      return $ mkSysLocalOrCoVar fs u ty
-
--- |Make several fresh local variables with the given types.
--- The variable's names are formed using the given string as the prefix.
---
-newLocalVars :: FastString -> [Type] -> VM [Var]
-newLocalVars fs = mapM (newLocalVar fs)
-
--- |Make a new local dummy variable.
---
-newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar (fsLit "vv")
-
--- |Make a fresh type variable with the given kind.
--- The variable's name is formed using the given string as the prefix.
---
-newTyVar :: FastString -> Kind -> VM Var
-newTyVar fs k
- = do u <- liftDs newUnique
-      return $ mkTyVar (mkSysTvName u fs) k
-
--- |Make a fresh coercion variable with the given kind.
-newCoVar :: FastString -> Kind -> VM Var
-newCoVar fs k
-  = do u <- liftDs newUnique
-       return $ mkCoVar (mkSystemVarName u fs) k
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
deleted file mode 100644
index ffe95f3cc4..0000000000
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ /dev/null
@@ -1,129 +0,0 @@
--- Extract from a list of type constructors those (1) which need to be vectorised and (2) those
--- that could be, but need not be vectorised (as a scalar representation is sufficient and more
--- efficient).  The type constructors that cannot be vectorised will be dropped.
---
--- A type constructor will only be vectorised if it is
---
--- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by
---     Haskell 98) and
--- (2) at least one of the type constructors that appears in its definition is also vectorised.
---
--- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no
--- need to vectorise that type constructor itself.  This holds, for example, for all enumeration
--- types.  As '([::])' is being vectorised, any type constructor whose definition involves
--- '([::])', either directly or indirectly, will be vectorised.
-
-module Vectorise.Type.Classify
-  ( classifyTyCons
-  )
-where
-
-import NameSet
-import UniqSet
-import UniqFM
-import DataCon
-import TyCon
-import TyCoRep
-import qualified Type
-import PrelNames
-import Digraph
-
--- |From a list of type constructors, extract those that can be vectorised, returning them in two
--- sets, where the first result list /must be/ vectorised and the second result list /need not be/
--- vectorised. The third result list are those type constructors that we cannot convert (either
--- because they use language extensions or because they dependent on type constructors for which
--- no vectorised version is available).
---
--- NB: In order to be able to vectorise a type constructor, we require members of the depending set
---     (i.e., those type constructors that the current one depends on) to be vectorised only if they
---     are also parallel (i.e., appear in the second argument to the function).
---
--- The first argument determines the /conversion status/ of external type constructors as follows:
---
--- * tycons which have converted versions are mapped to 'True'
--- * tycons which are not changed by vectorisation are mapped to 'False'
--- * tycons which haven't been converted (because they can't or weren't vectorised) are not
---   elements of the map
---
-classifyTyCons :: UniqFM Bool                  -- ^type constructor vectorisation status
-               -> NameSet                      -- ^tycons involving parallel arrays
-               -> [TyCon]                      -- ^type constructors that need to be classified
-               -> ( [TyCon]                    -- to be converted
-                  , [TyCon]                    -- need not be converted (but could be)
-                  , [TyCon]                    -- involve parallel arrays (whether converted or not)
-                  , [TyCon]                    -- can't be converted
-                  )
-classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyCons (tyConGroups tcs)
-  where
-    classify conv keep par novect _  _   []               = (conv, keep, par, novect)
-    classify conv keep par novect cs pts ((tcs, ds) : rs)
-      | can_convert && must_convert
-      = classify (tcs ++ conv) keep (par ++ tcs_par) novect (cs `addListToUFM` [(tc, True)  | tc <- tcs]) pts' rs
-      | can_convert
-      = classify conv (tcs ++ keep) (par ++ tcs_par) novect (cs `addListToUFM` [(tc, False) | tc <- tcs]) pts' rs
-      | otherwise
-      = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs
-      where
-        refs = ds `delListFromUniqSet` tcs
-
-          -- the tycons that directly or indirectly depend on parallel arrays
-        tcs_par | uniqSetAny ((`elemNameSet` parTyCons) . tyConName) refs = tcs
-                | otherwise = []
-
-        pts' = pts `extendNameSetList` map tyConName tcs_par
-
-        can_convert  = (isEmptyUniqSet (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `uniqSetMinusUFM` cs))
-                        && all convertable tcs)
-                       || isShowClass tcs
-        must_convert = anyUFM id (intersectUFM_C const cs (getUniqSet refs))
-                       && (not . isShowClass $ tcs)
-
-        -- We currently admit Haskell 2011-style data and newtype declarations as well as type
-        -- constructors representing classes.
-        convertable tc
-          = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc)
-            || isClassTyCon tc
-
-        -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a
-        --   vectorised definition (to be able to vectorise 'Num')
-        isShowClass [tc] = tyConName tc == showClassName
-        isShowClass _    = False
-
--- Used to group type constructors into mutually dependent groups.
---
-type TyConGroup = ([TyCon], UniqSet TyCon)
-
--- Compute mutually recursive groups of tycons in topological order.
---
-tyConGroups :: [TyCon] -> [TyConGroup]
-tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges)
-  where
-    edges :: [ Node TyCon (TyCon, UniqSet TyCon) ]
-    edges = [DigraphNode (tc, ds) tc (nonDetEltsUniqSet ds) | tc <- tcs
-                                , let ds = tyConsOfTyCon tc]
-            -- It's OK to use nonDetEltsUniqSet here as
-            -- stronglyConnCompFromEdgedVertices is still deterministic even
-            -- if the edges are in nondeterministic order as explained in
-            -- Note [Deterministic SCC] in Digraph.
-
-    mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds)
-    mk_grp (CyclicSCC els)       = (tcs, unionManyUniqSets dss)
-      where
-        (tcs, dss) = unzip els
-
--- |Collect the set of TyCons used by the representation of some data type.
---
-tyConsOfTyCon :: TyCon -> UniqSet TyCon
-tyConsOfTyCon = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons
-
--- |Collect the set of TyCons that occur in these types.
---
-tyConsOfTypes :: [Type] -> UniqSet TyCon
-tyConsOfTypes = unionManyUniqSets . map tyConsOfType
-
--- |Collect the set of TyCons that occur in this type.
---
-tyConsOfType :: Type -> UniqSet TyCon
-tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty
-  where not_tuple_or_unlifted tc = not (isUnliftedTyCon tc || isTupleTyCon tc)
-
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
deleted file mode 100644
index 9526feddaf..0000000000
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ /dev/null
@@ -1,455 +0,0 @@
-{-# LANGUAGE CPP #-}
-
--- Vectorise a modules type and class declarations.
---
--- This produces new type constructors and family instances top be included in the module toplevel
--- as well as bindings for worker functions, dfuns, and the like.
-
-module Vectorise.Type.Env (
-  vectTypeEnv,
-) where
-
-#include "HsVersions.h"
-
-import Vectorise.Env
-import Vectorise.Vect
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Type.TyConDecl
-import Vectorise.Type.Classify
-import Vectorise.Generic.PADict
-import Vectorise.Generic.PAMethods
-import Vectorise.Generic.PData
-import Vectorise.Generic.Description
-import Vectorise.Utils
-
-import CoreSyn
-import CoreUtils
-import CoreUnfold
-import DataCon
-import TyCon
-import CoAxiom
-import Type
-import FamInstEnv
-import Id
-import MkId
-import NameEnv
-import NameSet
-import UniqFM
-import OccName
-import Unique
-
-import Util
-import Outputable
-import DynFlags
-import FastString
-import MonadUtils
-
-import Control.Monad
-import Data.Maybe
-import Data.List
-
-
--- Note [Pragmas to vectorise tycons]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- All imported type constructors that are not mapped to a vectorised type in the vectorisation map
--- (possibly because the defining module was not compiled with vectorisation) may be used in scalar
--- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the
--- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code,
--- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised
--- code (i.e., it can only be used in scalar code).
---
--- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged
--- by vectorisation.  However, the representation of 'Int' by the 'I#' data constructor wrapping an
--- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need
--- to be confined to scalar code.
---
--- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type
--- constructors:
---
--- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
---     code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types
---     declared in a vectorised module.  This includes the case where the vectoriser determines that
---     the original representation of 'T' may be used in vectorised code (as it does not embed any
---     parallel arrays.)  This case is for type constructors that are *imported* from a non-
---     vectorised module, but that we want to use with full vectorisation support.
---
---     An example is the treatment of 'Ordering' and '[]'.  The former remains unchanged by
---     vectorisation, whereas the latter is fully vectorised.
---
---     'PData' and 'PRepr' instances are automatically generated by the vectoriser.
---
---     Type constructors declared with {-# VECTORISE type T #-} are treated in this manner.
---
--- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an
---     explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the
---     constructors of 'T' may not occur in vectorised code).
---
---     An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is
---     vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised
---     code. Instead, computations involving the representation need to be confined to scalar code.
---
---     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
---     by the vectoriser).
---
---     Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner
---     manner. (The vectoriser never treats a type constructor automatically in this manner.)
---
--- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly
---     provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together
---     with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its
---     constructors 'Cn' are represented by themselves in vectorised code.
---
---     An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed
---     any parallel arrays).  However, we do not want any automatic generation of class and family
---     instances, which is why Case (1) does not apply.
---
---     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
---     by the vectoriser).
---
---     Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.
---
--- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised
---     code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in
---     vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated
---     scalar subcomputations.
---
---     An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are
---     vectorised to '(:->)'.  However, the representation of '(->)' is not exposed in vectorised
---     code. Instead, computations involving the representation need to be confined to scalar code
---     and may be part of encapsulated scalar computations.
---
---     'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
---     by the vectoriser).
---
---     Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this
---     manner. (The vectoriser never treats a type constructor automatically in this manner.)
---
--- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}.
--- It implies that the class type constructor may be used in vectorised code together with its data
--- constructor.  We generally produce a vectorised version of the data type and data constructor.
--- We do not generate 'PData' and 'PRepr' instances for class type constructors.  This pragma is the
--- default for all type classes declared in a vectorised module, but the pragma can also be used
--- explitly on imported classes.
-
--- Note [Vectorising classes]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We vectorise classes essentially by just vectorising their desugared Core representation, but we
--- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl').
---
--- Here is an example illustrating the mapping — assume
---
---   class Num a where
---     (+) :: a -> a -> a
---
--- It desugars to
---
---   data Num a = D:Num { (+) :: a -> a -> a }
---
--- which we vectorise to
---
---  data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a }
---
--- while adding the following entries to the vectorisation map:
---
---   tycon  : Num   --> V:Num
---   datacon: D:Num --> D:V:Num
---   var    : (+) --> ($v+)
-
--- |Vectorise type constructor including class type constructors.
---
-vectTypeEnv :: [TyCon]                   -- Type constructors defined in this module
-            -> [CoreVect]                -- All 'VECTORISE [SCALAR] type' declarations in this module
-            -> [CoreVect]                -- All 'VECTORISE class' declarations in this module
-            -> VM ( [TyCon]              -- old TyCons ++ new TyCons
-                  , [FamInst]            -- New type family instances.
-                  , [(Var, CoreExpr)])   -- New top level bindings.
-vectTypeEnv tycons vectTypeDecls vectClassDecls
-  = do { traceVt "** vectTypeEnv" $ ppr tycons
-
-       ; let   -- {-# VECTORISE type T -#} (ONLY the imported tycons)
-             impVectTyCons          = (   [tycon | VectType False tycon Nothing <- vectTypeDecls]
-                                       ++ [tycon | VectClass tycon              <- vectClassDecls])
-                                      \\ tycons
-
-               -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/)
-             vectTyConsWithRHS      = [ (tycon, rhs)
-                                      | VectType False tycon (Just rhs) <- vectTypeDecls]
-
-               -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/)
-             scalarTyConsWithRHS    = [ (tycon, rhs)
-                                      | VectType True  tycon (Just rhs) <- vectTypeDecls]
-
-               -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS)
-             scalarTyConsNoRHS      = [tycon | VectType True tycon Nothing <- vectTypeDecls]
-
-               -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs?
-             vectSpecialTyConNames  = mkNameSet . map tyConName $
-                                        scalarTyConsNoRHS ++
-                                        map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)
-             notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
-
-         -- Build a map containing all vectorised type constructor. If the vectorised type
-         -- constructor differs from the original one, then it is mapped to 'True'; if they are
-         -- both the same, then it maps to 'False'.
-       ; vectTyCons          <- globalVectTyCons
-       ; let vectTyConBase    = mapUFM_Directly isDistinct vectTyCons    -- 'True' iff tc /= V[[tc]]
-             isDistinct u tc  = u /= getUnique tc
-             vectTyConFlavour = vectTyConBase
-                                `plusNameEnv`
-                                mkNameEnv [ (tyConName tycon, True)
-                                          | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]
-                                `plusNameEnv`
-                                mkNameEnv [ (tyConName tycon, False)  -- original representation
-                                          | tycon <- scalarTyConsNoRHS]
-
-
-           -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
-           -- that we could, but don't need to vectorise.  Type constructors that are not data
-           -- type constructors or use non-Haskell98 features are being dropped.  They may not
-           -- appear in vectorised code.  (We also drop the local type constructors appearing in a
-           -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
-           -- these are being handled separately.  NB: Some type constructors may be marked SCALAR
-           -- /and/ have an explicit right-hand side.)
-           --
-           -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose
-           -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs'
-           -- are all type constructors that cannot be vectorised.
-       ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$>
-                             globalParallelTyCons
-       ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons
-             (conv_tcs, keep_tcs, par_tcs, drop_tcs)
-               = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons
-
-       ; traceVt " known parallel : " $ ppr parallelTyCons
-       ; traceVt " VECT SCALAR    : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS)
-       ; traceVt " VECT [class]   : " $ ppr impVectTyCons
-       ; traceVt " VECT with rhs  : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS))
-       ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty
-       ; traceVt " reuse          : " $ ppr keep_tcs
-       ; traceVt " convert        : " $ ppr conv_tcs
-
-           -- warn the user about unvectorised type constructors
-       ; let explanation    = text "(They use unsupported language extensions"
-                          $$  text "or depend on type constructors that are" <+>
-                              text "not vectorised)"
-             drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) .
-                              filter (not . isTypeSynonymTyCon) $ drop_tcs
-       ; unless (null drop_tcs_nosyn) $
-           emitVt "Warning: cannot vectorise these type constructors:" $
-             pprQuotedList drop_tcs_nosyn $$ explanation
-
-       ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS
-
-       ; let mapping =
-                    -- Type constructors that we found we don't need to vectorise and those
-                    -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same
-                    -- representation in both unvectorised and vectorised code; they are not
-                    -- abstract.
-                  [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS]
-                    -- We do the same for type constructors declared VECTORISE SCALAR /without/
-                    -- an explicit right-hand side
-               ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS]
-       ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping
-
-           -- Vectorise all the data type declarations that we can and must vectorise (enter the
-           -- type and data constructors into the vectorisation map on-the-fly.)
-       ; new_tcs <- vectTyConDecls conv_tcs
-
-       ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$
-                                            ppr vTc <+> text "::" <+> ppr (dataConSig vTc))
-             dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc
-                           | otherwise                              = panic "dataConSig"
-       ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs)
-
-           -- We don't need new representation types for dictionary constructors. The constructors
-           -- are always fully applied, and we don't need to lift them to arrays as a dictionary
-           -- of a particular type always has the same value.
-       ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs
-             vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs
-
-           -- Build 'PRepr' and 'PData' instance type constructors and family instances for all
-           -- type constructors with vectorised representations.
-       ; reprs      <- mapM tyConRepr vect_tcs
-       ; repr_fis   <- zipWith3M buildPReprTyCon  orig_tcs vect_tcs reprs
-       ; pdata_fis  <- zipWith3M buildPDataTyCon  orig_tcs vect_tcs reprs
-       ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs
-
-       ; let fam_insts  = repr_fis ++ pdata_fis ++ pdatas_fis
-             repr_axs   = map famInstAxiom repr_fis
-             pdata_tcs  = famInstsRepTyCons pdata_fis
-             pdatas_tcs = famInstsRepTyCons pdatas_fis
-
-       ; updGEnv $ extendFamEnv fam_insts
-
-           -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of
-           -- the vectorised type constructors, and associate the type constructors with their dfuns
-           -- in the global environment.  We get back the dfun bindings (which we will subsequently
-           -- inject into the modules toplevel).
-       ; (_, binds) <- fixV $ \ ~(dfuns, _) ->
-           do { defTyConPAs (zipLazy vect_tcs dfuns)
-
-                  -- Query the 'PData' instance type constructors for type constructors that have a
-                  -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item
-                  --  (3) of "Note [Pragmas to vectorise tycons]" above).
-              ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS
-
-                  -- Build workers for all vectorised data constructors (except abstract ones)
-              ; sequence_ $
-                  zipWith3 vectDataConWorkers (orig_tcs  ++ scalarTyConsNoRHS)
-                                              (vect_tcs  ++ scalarTyConsNoRHS)
-                                              (pdata_tcs ++ pdata_scalar_tcs)
-
-                  -- Build a 'PA' dictionary for all type constructors (except abstract ones & those
-                  -- defined with an explicit right-hand side where the dictionary is user-supplied)
-              ; dfuns <- sequence $
-                           zipWith4 buildTyConPADict
-                                    vect_tcs
-                                    repr_axs
-                                    pdata_tcs
-                                    pdatas_tcs
-
-              ; binds <- takeHoisted
-              ; return (dfuns, binds)
-              }
-
-           -- Return the vectorised variants of type constructors as well as the generated instance
-           -- type constructors, family instances, and dfun bindings.
-       ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs
-                , fam_insts, binds)
-       }
-  where
-    addParallelTyConAndCons tycon
-      = do
-        { addGlobalParallelTyCon tycon
-        ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon
-                                          , AnId id <- dataConImplicitTyThings dc ]
-                                          -- Ignoring the promoted tycon; hope that's ok
-        }
-
-    -- Add a mapping from the original to vectorised type constructor to the vectorisation map.
-    -- Unless the type constructor is abstract, also mappings from the original's data constructors
-    -- to the vectorised type's data constructors.
-    --
-    -- We have three cases: (1) original and vectorised type constructor are the same, (2) the
-    -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or
-    -- (3) the name is not canonical.  In the third case, we additionally introduce a type synonym
-    -- with the canonical name that is set equal to the non-canonical name (so that we find the
-    -- right type constructor when reading vectorisation information from interface files).
-    --
-    defTyConDataCons (origTyCon, vectTyCon, isAbstract)
-      = do
-        { canonName <- mkLocalisedName mkVectTyConOcc origName
-        ; if    origName == vectName                             -- Case (1)
-             || vectName == canonName                            -- Case (2)
-          then do
-          { defTyCon origTyCon vectTyCon                         -- T  --> vT
-          ; defDataCons                                          -- Ci --> vCi
-          ; return Nothing
-          }
-          else do                                                 -- Case (3)
-          { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon)  -- type S = vT
-          ; defTyCon origTyCon synTyCon                           -- T  --> S
-          ; defDataCons                                           -- Ci --> vCi
-          ; return $ Just synTyCon
-          }
-        }
-      where
-        origName  = tyConName origTyCon
-        vectName  = tyConName vectTyCon
-
-        mkSyn canonName ty = buildSynTyCon canonName [] (typeKind ty) [] ty
-
-        defDataCons
-          | isAbstract = return ()
-          | otherwise
-          = do { MASSERT(tyConDataCons origTyCon `equalLength` tyConDataCons vectTyCon)
-               ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
-               }
-
-
--- Helpers --------------------------------------------------------------------
-
-buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var
-buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc
- = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc
-
--- Produce a custom-made worker for the data constructors of a vectorised data type.  This includes
--- all data constructors that may be used in vectorised code — i.e., all data constructors of data
--- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side.  Also adds a mapping
--- from the original to vectorised worker into the vectorisation map.
---
--- FIXME: It's not nice that we need create a special worker after the data constructors has
---   already been constructed.  Also, I don't think the worker is properly added to the data
---   constructor.  Seems messy.
-vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM ()
-vectDataConWorkers orig_tc vect_tc arr_tc
-  = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc)
-
-       ; bs <- sequence
-             . zipWith3 def_worker  (tyConDataCons orig_tc) rep_tys
-             $ zipWith4 mk_data_con (tyConDataCons vect_tc)
-                                    rep_tys
-                                    (inits rep_tys)
-                                    (tail $ tails rep_tys)
-        ; mapM_ (uncurry hoistBinding) bs
-        }
-  where
-    tyvars   = tyConTyVars vect_tc
-    var_tys  = mkTyVarTys tyvars
-    ty_args  = map Type var_tys
-    res_ty   = mkTyConApp vect_tc var_tys
-
-    cons     = tyConDataCons vect_tc
-    arity    = length cons
-    [arr_dc] = tyConDataCons arr_tc
-
-    rep_tys  = map dataConRepArgTys $ tyConDataCons vect_tc
-
-    mk_data_con con tys pre post
-      = do dflags <- getDynFlags
-           liftM2 (,) (vect_data_con con)
-                      (lift_data_con tys pre post (mkDataConTag dflags con))
-
-    sel_replicate len tag
-      | arity > 1 = do
-                      rep <- builtin (selReplicate arity)
-                      return [rep `mkApps` [len, tag]]
-
-      | otherwise = return []
-
-    vect_data_con con = return $ mkConApp con ty_args
-    lift_data_con tys pre_tys post_tys tag
-      = do
-          len  <- builtin liftingContext
-          args <- mapM (newLocalVar (fsLit "xs"))
-                  =<< mapM mkPDataType tys
-
-          sel  <- sel_replicate (Var len) tag
-
-          pre   <- mapM emptyPD (concat pre_tys)
-          post  <- mapM emptyPD (concat post_tys)
-
-          return . mkLams (len : args)
-                 . wrapFamInstBody arr_tc var_tys
-                 . mkConApp arr_dc
-                 $ ty_args ++ sel ++ pre ++ map Var args ++ post
-
-    def_worker data_con arg_tys mk_body
-      = do
-          arity <- polyArity tyvars
-          body <- closedV
-                . inBind orig_worker
-                . polyAbstract tyvars $ \args ->
-                  liftM (mkLams (tyvars ++ args) . vectorised)
-                $ buildClosures tyvars [] [] arg_tys res_ty mk_body
-
-          raw_worker <- mkVectId orig_worker (exprType body)
-          let vect_worker = raw_worker `setIdUnfolding`
-                              mkInlineUnfoldingWithArity arity body
-          defGlobalVar orig_worker vect_worker
-          return (vect_worker, body)
-      where
-        orig_worker = dataConWorkId data_con
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
deleted file mode 100644
index 684754684b..0000000000
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-
-module Vectorise.Type.TyConDecl (
-  vectTyConDecls
-) where
-
-import Vectorise.Type.Type
-import Vectorise.Monad
-import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
-import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName )
-import OccName
-import Class
-import Type
-import TyCon
-import DataCon
-import DynFlags
-import BasicTypes( DefMethSpec(..) )
-import SrcLoc( SrcSpan, noSrcSpan )
-import Var
-import Name
-import Outputable
-import Util
-import Control.Monad
-
-
--- |Vectorise some (possibly recursively defined) type constructors.
---
-vectTyConDecls :: [TyCon] -> VM [TyCon]
-vectTyConDecls tcs = fixV $ \tcs' ->
-  do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
-     ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
-     ; zipWithM vectTyConDecl tcs names'
-     }
-
--- |Vectorise a single type constructor.
---
-vectTyConDecl :: TyCon -> Name -> VM TyCon
-vectTyConDecl tycon name'
-
-      -- Type constructor representing a type class
-  | Just cls <- tyConClass_maybe tycon
-  = do { unless (null $ classATs cls) $
-           do dflags <- getDynFlags
-              cantVectorise dflags "Associated types are not yet supported" (ppr cls)
-
-           -- vectorise superclass constraint (types)
-       ; theta' <- mapM vectType (classSCTheta cls)
-
-           -- vectorise method selectors
-       ; let opItems      = classOpItems cls
-             Just datacon = tyConSingleDataCon_maybe tycon
-             argTys       = dataConRepArgTys datacon                      -- all selector types
-             opTys        = drop (length argTys - length opItems) argTys  -- only method types
-       ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys]
-
-           -- construct the vectorised class (this also creates the class type constructors and its
-           -- data constructor)
-           --
-           -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
-       ; cls' <- liftDs $
-                   buildClass
-                     name'                      -- new name: "V:Class"
-                     (tyConBinders tycon)       -- keep original kind
-                     (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety
-                     (snd . classTvsFds $ cls)  -- keep the original functional dependencies
-                     (Just (
-                         theta',                 -- superclasses
-                         [],                     -- no associated types (for the moment)
-                         methods',               -- method info
-                         (classMinimalDef cls))) -- Inherit minimal complete definition from cls
-
-           -- the original dictionary constructor must map to the vectorised one
-       ; let tycon'        = classTyCon cls'
-             Just datacon  = tyConSingleDataCon_maybe tycon
-             Just datacon' = tyConSingleDataCon_maybe tycon'
-       ; defDataCon datacon datacon'
-
-           -- the original superclass and methods selectors must map to the vectorised ones
-       ; let selIds  = classAllSelIds cls
-             selIds' = classAllSelIds cls'
-       ; zipWithM_ defGlobalVar selIds selIds'
-
-           -- return the type constructor of the vectorised class
-       ; return tycon'
-       }
-
-       -- Regular algebraic type constructor — for now, Haskell 2011-style only
-  | isAlgTyCon tycon
-  = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
-           do dflags <- getDynFlags
-              cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
-
-           -- vectorise the data constructor of the class tycon
-       ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-
-           -- keep the original GADT flags
-       ; let gadt_flag = isGadtSyntaxTyCon tycon
-
-           -- build the vectorised type constructor
-       ; tc_rep_name <- mkDerivedName mkTyConRepOcc name'
-       ; return $ mkAlgTyCon
-                    name'                   -- new name
-                    (tyConBinders tycon)
-                    (tyConResKind tycon)    -- keep original kind
-                    (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety
-                    Nothing
-                    []                      -- no stupid theta
-                    rhs'                    -- new constructor defs
-                    (VanillaAlgTyCon tc_rep_name)
-                    gadt_flag               -- whether in GADT syntax
-       }
-
-  -- some other crazy thing that we don't handle
-  | otherwise
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
-
--- |Vectorise a class method.  (Don't enter it into the vectorisation map yet.)
---
-vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo
-vectMethod id defMeth ty
- = do {   -- Vectorise the method type.
-      ; ty' <- vectType ty
-
-          -- Create a name for the vectorised method.
-      ; id' <- mkVectId id ty'
-
-      ; return  (Var.varName id', ty', defMethSpecOfDefMeth defMeth)
-      }
-
--- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in
---   the `DefMeth` constructor of the `DefMeth`.
-defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type))
-defMethSpecOfDefMeth Nothing = Nothing
-defMethSpecOfDefMeth (Just (_, VanillaDM))    = Just VanillaDM
-defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty))
-
--- |Vectorise the RHS of an algebraic type.
---
-vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
-vectAlgTyConRhs tc (AbstractTyCon {})
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
-vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
-                               , is_enum   = is_enum
-                               })
-  = do { data_cons' <- mapM vectDataCon data_cons
-       ; zipWithM_ defDataCon data_cons data_cons'
-       ; return $ DataTyCon { data_cons = data_cons'
-                            , is_enum   = is_enum
-                            }
-       }
-
-vectAlgTyConRhs tc (TupleTyCon { data_con = con })
-  = vectAlgTyConRhs tc (DataTyCon { data_cons = [con], is_enum = False })
-    -- I'm not certain this is what you want to do for tuples,
-    -- but it's the behaviour we had before I refactored the
-    -- representation of AlgTyConRhs to add tuples
-
-vectAlgTyConRhs tc (SumTyCon { data_cons = cons })
-  = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably
-    -- also broken when the tuple is unboxed.
-    vectAlgTyConRhs tc (DataTyCon { data_cons = cons
-                                  , is_enum = all (((==) 0) . dataConRepArity) cons })
-
-vectAlgTyConRhs tc (NewTyCon {})
-  = do dflags <- getDynFlags
-       cantVectorise dflags noNewtypeErr (ppr tc)
-  where
-    noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
-
--- |Vectorise a data constructor by vectorising its argument and return types..
---
-vectDataCon :: DataCon -> VM DataCon
-vectDataCon dc
-  | not . null $ ex_tvs
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
-  | not . null $ eq_spec
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
-  | not . null $ dataConFieldLabels dc
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
-  | not . null $ theta
-  = do dflags <- getDynFlags
-       cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
-  | otherwise
-  = do { name'   <- mkLocalisedName mkVectDataConOcc name
-       ; tycon'  <- vectTyCon tycon
-       ; arg_tys <- mapM vectType rep_arg_tys
-       ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
-       ; fam_envs  <- readGEnv global_fam_inst_env
-       ; rep_nm    <- liftDs $ newTyConRepName name'
-       ; liftDs $ buildDataCon fam_envs
-                    name'
-                    (dataConIsInfix dc)            -- infix if the original is
-                    rep_nm
-                    (dataConSrcBangs dc)           -- strictness as original constructor
-                    (Just $ dataConImplBangs dc)
-                    []                             -- no labelled fields for now
-                    univ_bndrs                     -- universally quantified vars
-                    []                             -- no existential tvs for now
-                    []                             -- no equalities for now
-                    []                             -- no context for now
-                    arg_tys                        -- argument types
-                    ret_ty                         -- return type
-                    tycon'                         -- representation tycon
-       }
-  where
-    name        = dataConName dc
-    rep_arg_tys = dataConRepArgTys dc
-    tycon       = dataConTyCon dc
-    (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
-    univ_bndrs  = dataConUnivTyVarBinders dc
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
deleted file mode 100644
index 88d3f565f3..0000000000
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ /dev/null
@@ -1,87 +0,0 @@
--- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM.
-
-module Vectorise.Type.Type
-  ( vectTyCon
-  , vectAndLiftType
-  , vectType
-  )
-where
-
-import Vectorise.Utils
-import Vectorise.Monad
-import Vectorise.Builtins
-import TcType
-import Type
-import TyCoRep
-import TyCon
-import Control.Monad
-import Control.Applicative
-import Data.Maybe
-import Outputable
-import Prelude -- avoid redundant import warning due to AMP
-
--- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded
--- parallel arrays), the vectorised version is the same as the original.
---
-vectTyCon :: TyCon -> VM TyCon
-vectTyCon tc = maybe tc id <$> lookupTyCon tc
-
--- |Produce the vectorised and lifted versions of a type.
---
--- NB: Here we are limited to properly handle predicates at the toplevel only.  Anything embedded
---     in what is called the 'body_ty' below will end up as an argument to the type family 'PData'.
---
-vectAndLiftType :: Type -> VM (Type, Type)
-vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
-vectAndLiftType ty
-  = do { padicts  <- liftM catMaybes $ mapM paDictArgType tyvars
-       ; vmono_ty <- vectType mono_ty
-       ; lmono_ty <- mkPDataType vmono_ty
-       ; return (abstractType tyvars (padicts ++ theta) vmono_ty,
-                 abstractType tyvars (padicts ++ theta) lmono_ty)
-       }
-  where
-    (tyvars, phiTy)  = splitForAllTys ty
-    (theta, mono_ty) = tcSplitPhiTy phiTy
-
--- |Vectorise a type.
---
--- For each quantified var we need to add a PA dictionary out the front of the type.
--- So          forall a.         C  a => a -> a
--- turns into  forall a. PA a => Cv a => a :-> a
---
-vectType :: Type -> VM Type
-vectType ty
-  | Just ty'  <- coreView ty
-  = vectType ty'
-vectType (TyVarTy tv)      = return $ TyVarTy tv
-vectType (LitTy l)         = return $ LitTy l
-vectType (AppTy ty1 ty2)   = AppTy <$> vectType ty1 <*> vectType ty2
-vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys
-vectType (FunTy ty1 ty2)
-  | isPredTy ty1
-  = mkFunTy <$> vectType ty1 <*> vectType ty2   -- don't build a closure for dictionary abstraction
-  | otherwise
-  = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2]
-vectType ty@(ForAllTy {})
- = do {   -- strip off consecutive foralls
-      ; let (tyvars, tyBody) = splitForAllTys ty
-
-          -- vectorise the body
-      ; vtyBody <- vectType tyBody
-
-          -- make a PA dictionary for each of the type variables
-      ; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars
-
-          -- add the PA dictionaries after the foralls
-      ; return $ abstractType tyvars dictsPA vtyBody
-      }
-vectType ty@(CastTy {})
-  = pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty)
-vectType ty@(CoercionTy {})
-  = pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty)
-
--- |Add quantified vars and dictionary parameters to the front of a type.
---
-abstractType :: [TyVar] -> [Type] -> Type -> Type
-abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts
diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs
deleted file mode 100644
index 733eeb9cfd..0000000000
--- a/compiler/vectorise/Vectorise/Utils.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-module Vectorise.Utils (
-  module Vectorise.Utils.Base,
-  module Vectorise.Utils.Closure,
-  module Vectorise.Utils.Hoisting,
-  module Vectorise.Utils.PADict,
-  module Vectorise.Utils.Poly,
-
-  -- * Annotated Exprs
-  collectAnnTypeArgs,
-  collectAnnDictArgs,
-  collectAnnTypeBinders,
-  collectAnnValBinders,
-  isAnnTypeArg,
-
-  -- * PD Functions
-  replicatePD, emptyPD, packByTagPD,
-  combinePD, liftPD,
-
-  -- * Scalars
-  isScalar, zipScalars, scalarClosure,
-
-  -- * Naming
-  newLocalVar
-) where
-
-import Vectorise.Utils.Base
-import Vectorise.Utils.Closure
-import Vectorise.Utils.Hoisting
-import Vectorise.Utils.PADict
-import Vectorise.Utils.Poly
-import Vectorise.Monad
-import Vectorise.Builtins
-import CoreSyn
-import CoreUtils
-import Id
-import Type
-import Control.Monad
-
-
--- Annotated Exprs ------------------------------------------------------------
-
-collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
-collectAnnTypeArgs expr = go expr []
-  where
-    go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
-    go e                             tys = (e, tys)
-
-collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann])
-collectAnnDictArgs expr = go expr []
-  where
-    go e@(_, AnnApp f arg) dicts
-      | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts)
-      | otherwise                              = (e, dicts)
-    go e                        dicts          = (e, dicts)
-
-collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
-collectAnnTypeBinders expr = go [] expr
-  where
-    go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e
-    go bs e                           = (reverse bs, e)
-
--- |Collect all consecutive value binders that are not dictionaries.
---
-collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
-collectAnnValBinders expr = go [] expr
-  where
-    go bs (_, AnnLam b e) | isId b
-                          && (not . isPredTy . idType $ b) = go (b : bs) e
-    go bs e                                                = (reverse bs, e)
-
-isAnnTypeArg :: AnnExpr b ann -> Bool
-isAnnTypeArg (_, AnnType _) = True
-isAnnTypeArg _              = False
-
-
--- PD "Parallel Data" Functions -----------------------------------------------
---
---   Given some data that has a PA dictionary, we can convert it to its
---   representation type, perform some operation on the data, then convert it back.
---
---   In the DPH backend, the types of these functions are defined
---   in dph-common/D.A.P.Lifted/PArray.hs
---
-
--- |An empty array of the given type.
---
-emptyPD :: Type -> VM CoreExpr
-emptyPD = paMethod emptyPDVar emptyPD_PrimVar
-
--- |Produce an array containing copies of a given element.
---
-replicatePD :: CoreExpr     -- ^ Number of copies in the resulting array.
-            -> CoreExpr     -- ^ Value to replicate.
-            -> VM CoreExpr
-replicatePD len x
-  = liftM (`mkApps` [len,x])
-        $ paMethod replicatePDVar replicatePD_PrimVar (exprType x)
-
--- |Select some elements from an array that correspond to a particular tag value and pack them into a new
--- array.
---
--- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:]  3 [:1, 2, 1, 2, 3, 2:] 2
--- >   ==> [:42, 50, 49:]
---
-packByTagPD :: Type       -- ^ Element type.
-            -> CoreExpr   -- ^ Source array.
-            -> CoreExpr   -- ^ Length of resulting array.
-            -> CoreExpr   -- ^ Tag values of elements in source array.
-            -> CoreExpr   -- ^ The tag value for the elements to select.
-            -> VM CoreExpr
-packByTagPD ty xs len tags t
-  = liftM (`mkApps` [xs, len, tags, t])
-          (paMethod packByTagPDVar packByTagPD_PrimVar ty)
-
--- |Combine some arrays based on a selector.  The selector says which source array to choose for each
--- element of the resulting array.
---
-combinePD :: Type         -- ^ Element type
-          -> CoreExpr     -- ^ Length of resulting array
-          -> CoreExpr     -- ^ Selector.
-          -> [CoreExpr]   -- ^ Arrays to combine.
-          -> VM CoreExpr
-combinePD ty len sel xs
-  = liftM (`mkApps` (len : sel : xs))
-          (paMethod (combinePDVar n) (combinePD_PrimVar n) ty)
-  where
-    n = length xs
-
--- |Like `replicatePD` but use the lifting context in the vectoriser state.
---
-liftPD :: CoreExpr -> VM CoreExpr
-liftPD x
-  = do
-      lc <- builtin liftingContext
-      replicatePD (Var lc) x
-
-
--- Scalars --------------------------------------------------------------------
-
-isScalar :: Type -> VM Bool
-isScalar ty
-  = do
-    { scalar <- builtin scalarClass
-    ; existsInst scalar [ty]
-    }
-
-zipScalars :: [Type] -> Type -> VM CoreExpr
-zipScalars arg_tys res_ty
-  = do
-    { scalar <- builtin scalarClass
-    ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args
-    ; zipf <- builtin (scalarZip $ length arg_tys)
-    ; return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns
-    }
-    where
-      ty_args = arg_tys ++ [res_ty]
-
-scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr
-scalarClosure arg_tys res_ty scalar_fun array_fun
-  = do
-    { ctr <- builtin (closureCtrFun $ length arg_tys)
-    ; pas <- mapM paDictOfType (init arg_tys)
-    ; return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty])
-                       `mkApps`   (pas ++ [scalar_fun, array_fun])
-    }
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
deleted file mode 100644
index 88058e22d9..0000000000
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ /dev/null
@@ -1,259 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Vectorise.Utils.Base
-  ( voidType
-  , newLocalVVar
-
-  , mkDataConTag
-  , mkWrapType
-  , mkClosureTypes
-  , mkPReprType
-  , mkPDataType, mkPDatasType
-  , splitPrimTyCon
-  , mkBuiltinCo
-
-  , wrapNewTypeBodyOfWrap
-  , unwrapNewTypeBodyOfWrap
-  , wrapNewTypeBodyOfPDataWrap
-  , unwrapNewTypeBodyOfPDataWrap
-  , wrapNewTypeBodyOfPDatasWrap
-  , unwrapNewTypeBodyOfPDatasWrap
-
-  , pdataReprTyCon
-  , pdataReprTyConExact
-  , pdatasReprTyConExact
-  , pdataUnwrapScrut
-
-  , preprFamInst
-) where
-
-import Vectorise.Monad
-import Vectorise.Vect
-import Vectorise.Builtins
-
-import CoreSyn
-import CoreUtils
-import FamInstEnv
-import Coercion
-import Type
-import TyCon
-import DataCon
-import MkId
-import DynFlags
-import FastString
-
-#include "HsVersions.h"
-
--- Simple Types ---------------------------------------------------------------
-
-voidType :: VM Type
-voidType = mkBuiltinTyConApp voidTyCon []
-
-
--- Name Generation ------------------------------------------------------------
-
-newLocalVVar :: FastString -> Type -> VM VVar
-newLocalVVar fs vty
-  = do
-      lty <- mkPDataType vty
-      vv  <- newLocalVar fs vty
-      lv  <- newLocalVar fs lty
-      return (vv,lv)
-
-
--- Constructors ---------------------------------------------------------------
-
-mkDataConTag :: DynFlags -> DataCon -> CoreExpr
-mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ
-
-
--- Type Construction ----------------------------------------------------------
-
--- |Make an application of the 'Wrap' type constructor.
---
-mkWrapType :: Type -> VM Type
-mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
-
--- |Make an application of the closure type constructor.
---
-mkClosureTypes :: [Type] -> Type -> VM Type
-mkClosureTypes = mkBuiltinTyConApps closureTyCon
-
--- |Make an application of the 'PRepr' type constructor.
---
-mkPReprType :: Type -> VM Type
-mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
-
--- | Make an application of the 'PData' tycon to some argument.
---
-mkPDataType :: Type -> VM Type
-mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
-
--- | Make an application of the 'PDatas' tycon to some argument.
---
-mkPDatasType :: Type -> VM Type
-mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty]
-
--- Make an application of a builtin type constructor to some arguments.
---
-mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
-mkBuiltinTyConApp get_tc tys
-  = do { tc <- builtin get_tc
-       ; return $ mkTyConApp tc tys
-       }
-
--- Make a cascading application of a builtin type constructor.
---
-mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
-mkBuiltinTyConApps get_tc tys ty
- = do { tc <- builtin get_tc
-      ; return $ foldr (mk tc) ty tys
-      }
-  where
-    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
-
-
--- Type decomposition ---------------------------------------------------------
-
--- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
---
-splitPrimTyCon :: Type -> Maybe TyCon
-splitPrimTyCon ty
-  | Just (tycon, []) <- splitTyConApp_maybe ty
-  , isPrimTyCon tycon
-  = Just tycon
-  | otherwise = Nothing
-
-
--- Coercion Construction -----------------------------------------------------
-
--- |Make a representational coercion to some builtin type.
---
-mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
-mkBuiltinCo get_tc
-  = do { tc <- builtin get_tc
-       ; return $ mkTyConAppCo Representational tc []
-       }
-
-
--- Wrapping and unwrapping the 'Wrap' newtype ---------------------------------
-
--- |Apply the constructor wrapper of the 'Wrap' /newtype/.
---
-wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
-wrapNewTypeBodyOfWrap e ty
-  = do { wrap_tc <- builtin wrapTyCon
-       ; return $ wrapNewTypeBody wrap_tc [ty] e
-       }
-
--- |Strip the constructor wrapper of the 'Wrap' /newtype/.
---
-unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
-unwrapNewTypeBodyOfWrap e ty
-  = do { wrap_tc <- builtin wrapTyCon
-       ; return $ unwrapNewTypeBody wrap_tc [ty] e
-       }
-
--- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
---
-wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
-wrapNewTypeBodyOfPDataWrap e ty
-  = do { wrap_tc  <- builtin wrapTyCon
-       ; pwrap_tc <- pdataReprTyConExact wrap_tc
-       ; return $ wrapNewTypeBody pwrap_tc [ty] e
-       }
-
--- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
---
-unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
-unwrapNewTypeBodyOfPDataWrap e ty
-  = do { wrap_tc  <- builtin wrapTyCon
-       ; pwrap_tc <- pdataReprTyConExact wrap_tc
-       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
-       }
-
--- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
---
-wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
-wrapNewTypeBodyOfPDatasWrap e ty
-  = do { wrap_tc  <- builtin wrapTyCon
-       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
-       ; return $ wrapNewTypeBody pwrap_tc [ty] e
-       }
-
--- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
---
-unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
-unwrapNewTypeBodyOfPDatasWrap e ty
-  = do { wrap_tc  <- builtin wrapTyCon
-       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
-       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
-       }
-
-
--- 'PData' representation types ----------------------------------------------
-
--- |Get the representation tycon of the 'PData' data family for a given type.
---
--- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in
--- 'Vectorise.Generic.Description':
---
---   @pdataReprTyCon {Sum2} = {PDataSum2}@
---
--- The type for which we look up a 'PData' instance may be more specific than the type in the
--- instance declaration.  In that case the second component of the result will be more specific than
--- a set of distinct type variables.
---
-pdataReprTyCon :: Type -> VM (TyCon, [Type])
-pdataReprTyCon ty
-  = do
-    { FamInstMatch { fim_instance = famInst
-                   , fim_tys      = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty])
-    ; return (dataFamInstRepTyCon famInst, tys)
-    }
-
--- |Get the representation tycon of the 'PData' data family for a given type constructor.
---
--- For example, for a binary type constructor 'T', we determine the representation type constructor
--- for 'PData (T a b)'.
---
-pdataReprTyConExact :: TyCon -> VM TyCon
-pdataReprTyConExact tycon
-  = do {   -- look up the representation tycon; if there is a match at all, it will be exact
-       ;   -- (i.e.,' _tys' will be distinct type variables)
-       ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
-       ; return ptycon
-       }
-
--- |Get the representation tycon of the 'PDatas' data family for a given type constructor.
---
--- For example, for a binary type constructor 'T', we determine the representation type constructor
--- for 'PDatas (T a b)'.
---
-pdatasReprTyConExact :: TyCon -> VM TyCon
-pdatasReprTyConExact tycon
-  = do {   -- look up the representation tycon; if there is a match at all, it will be exact
-       ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
-       ; return $ dataFamInstRepTyCon ptycon
-       }
-  where
-    pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty])
-
--- |Unwrap a 'PData' representation scrutinee.
---
-pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon)
-pdataUnwrapScrut (ve, le)
-  = do { (tc, arg_tys) <- pdataReprTyCon ty
-       ; let [dc] = tyConDataCons tc
-       ; return (ve, unwrapFamInstScrut tc arg_tys le, dc)
-       }
-  where
-    ty = exprType ve
-
-
--- 'PRepr' representation types ----------------------------------------------
-
--- |Get the representation tycon of the 'PRepr' type family for a given type.
---
-preprFamInst :: Type -> VM FamInstMatch
-preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
deleted file mode 100644
index 118f34dfbf..0000000000
--- a/compiler/vectorise/Vectorise/Utils/Closure.hs
+++ /dev/null
@@ -1,161 +0,0 @@
--- |Utils concerning closure construction and application.
-
-module Vectorise.Utils.Closure
-  ( mkClosure
-  , mkClosureApp
-  , buildClosures
-  )
-where
-
-import Vectorise.Builtins
-import Vectorise.Vect
-import Vectorise.Monad
-import Vectorise.Utils.Base
-import Vectorise.Utils.PADict
-import Vectorise.Utils.Hoisting
-
-import CoreSyn
-import Type
-import MkCore
-import CoreUtils
-import TyCon
-import DataCon
-import MkId
-import TysWiredIn
-import BasicTypes( Boxity(..) )
-import FastString
-
-
--- |Make a closure.
---
-mkClosure :: Type       -- ^ Type of the argument.
-          -> Type       -- ^ Type of the result.
-          -> Type       -- ^ Type of the environment.
-          -> VExpr      -- ^ The function to apply.
-          -> VExpr      -- ^ The environment to use.
-          -> VM VExpr
-mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
- = do dict <- paDictOfType env_ty
-      mkv  <- builtin closureVar
-      mkl  <- builtin liftedClosureVar
-      return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],
-              Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
-
--- |Make a closure application.
---
-mkClosureApp :: Type      -- ^ Type of the argument.
-             -> Type      -- ^ Type of the result.
-             -> VExpr     -- ^ Closure to apply.
-             -> VExpr     -- ^ Argument to use.
-             -> VM VExpr
-mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
- = do vapply <- builtin applyVar
-      lapply <- builtin liftedApplyVar
-      lc     <- builtin liftingContext
-      return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],
-              Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
-
--- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function.  The length of
--- the list of types of arguments determines the arity.
---
--- In addition to a set of type variables, a set of value variables is passed during closure
--- /construction/.  In contrast, the closure environment and the arguments are passed during closure
--- application.
---
-buildClosures :: [TyVar]    -- ^ Type variables passed during closure construction.
-              -> [Var]      -- ^ Variables passed during closure construction.
-              -> [VVar]     -- ^ Variables in the environment.
-              -> [Type]     -- ^ Type of the arguments.
-              -> Type       -- ^ Type of result.
-              -> VM VExpr
-              -> VM VExpr
-buildClosures _tvs _vars _env [] _res_ty mk_body
- = mk_body
-buildClosures tvs vars env [arg_ty] res_ty mk_body
- =  buildClosure tvs vars env arg_ty res_ty mk_body
-buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body
- = do { res_ty' <- mkClosureTypes arg_tys res_ty
-      ; arg     <- newLocalVVar (fsLit "x") arg_ty
-      ; buildClosure tvs vars env arg_ty res_ty'
-          . hoistPolyVExpr tvs vars (Inline (length env + 1))
-          $ do { lc     <- builtin liftingContext
-               ; clo    <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body
-               ; return $ vLams lc (env ++ [arg]) clo
-               }
-      }
-
--- Build a closure taking one extra argument during closure application.
---
--- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>)
---   where
---     f  = \env v -> case env of <x1,...,xn> -> e x1 ... xn v
---     f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v
---
--- In addition to a set of type variables, a set of value variables is passed during closure
--- /construction/.  In contrast, the closure environment and the closure argument are passed during
--- closure application.
---
-buildClosure :: [TyVar]         -- ^Type variables passed during closure construction.
-             -> [Var]           -- ^Variables passed during closure construction.
-             -> [VVar]          -- ^Variables in the environment.
-             -> Type            -- ^Type of the closure argument.
-             -> Type            -- ^Type of the result.
-             -> VM VExpr
-             -> VM VExpr
-buildClosure tvs vars vvars arg_ty res_ty mk_body
-  = do { (env_ty, env, bind) <- buildEnv vvars
-       ; env_bndr <- newLocalVVar (fsLit "env") env_ty
-       ; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
-
-           -- generate the closure function as a hoisted binding
-       ; fn <- hoistPolyVExpr tvs vars (Inline 2) $
-                 do { lc     <- builtin liftingContext
-                    ; body   <- mk_body
-                    ; return . vLams lc [env_bndr, arg_bndr]
-                             $ bind (vVar env_bndr)
-                                    (vVarApps lc body (vvars ++ [arg_bndr]))
-                    }
-
-       ; mkClosure arg_ty res_ty env_ty fn env
-       }
-
--- Build the environment for a single closure.
---
-buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr)
-buildEnv []
- = do
-      ty    <- voidType
-      void  <- builtin voidVar
-      pvoid <- builtin pvoidVar
-      return (ty, vVar (void, pvoid), \_ body -> body)
-buildEnv [v]
- = return (vVarType v, vVar v,
-           \env body -> vLet (vNonRec v env) body)
-buildEnv vs
- = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty
-
-      let venv_con   = tupleDataCon Boxed (length vs)
-          [lenv_con] = tyConDataCons lenv_tc
-
-          venv       = mkCoreTup (map Var vvs)
-          lenv       = Var (dataConWrapId lenv_con)
-                       `mkTyApps` lenv_tyargs
-                       `mkApps`   map Var lvs
-
-          vbind env body = mkWildCase env ty (exprType body)
-                           [(DataAlt venv_con, vvs, body)]
-
-          lbind env body =
-            let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env
-            in
-            mkWildCase scrut (exprType scrut) (exprType body)
-              [(DataAlt lenv_con, lvs, body)]
-
-          bind (venv, lenv) (vbody, lbody) = (vbind venv vbody,
-                                              lbind lenv lbody)
-
-      return (ty, (venv, lenv), bind)
-  where
-    (vvs, lvs) = unzip vs
-    tys        = map vVarType vs
-    ty         = mkBoxedTupleTy tys
diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
deleted file mode 100644
index 05883457bf..0000000000
--- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-module Vectorise.Utils.Hoisting
-  ( Inline(..)
-  , addInlineArity
-  , inlineMe
-
-  , hoistBinding
-  , hoistExpr
-  , hoistVExpr
-  , hoistPolyVExpr
-  , takeHoisted
-  )
-where
-
-import Vectorise.Monad
-import Vectorise.Env
-import Vectorise.Vect
-import Vectorise.Utils.Poly
-
-import CoreSyn
-import CoreUtils
-import CoreUnfold
-import Type
-import Id
-import BasicTypes  (Arity)
-import FastString
-import Control.Monad
-import Control.Applicative
-import Prelude -- avoid redundant import warning due to AMP
-
--- Inline ---------------------------------------------------------------------
-
--- |Records whether we should inline a particular binding.
---
-data Inline
-        = Inline Arity
-        | DontInline
-
--- |Add to the arity contained within an `Inline`, if any.
---
-addInlineArity :: Inline -> Int -> Inline
-addInlineArity (Inline m) n = Inline (m+n)
-addInlineArity DontInline _ = DontInline
-
--- |Says to always inline a binding.
---
-inlineMe :: Inline
-inlineMe = Inline 0
-
-
--- Hoisting --------------------------------------------------------------------
-
-hoistBinding :: Var -> CoreExpr -> VM ()
-hoistBinding v e = updGEnv $ \env ->
-  env { global_bindings = (v,e) : global_bindings env }
-
-hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
-hoistExpr fs expr inl
-  = do
-      var <- mk_inline `liftM` newLocalVar fs (exprType expr)
-      hoistBinding var expr
-      return var
-  where
-    mk_inline var = case inl of
-                      Inline arity -> var `setIdUnfolding`
-                                      mkInlineUnfoldingWithArity arity expr
-                      DontInline   -> var
-
-hoistVExpr :: VExpr -> Inline -> VM VVar
-hoistVExpr (ve, le) inl
-  = do
-      fs <- getBindName
-      vv <- hoistExpr ('v' `consFS` fs) ve inl
-      lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
-      return (vv, lv)
-
--- |Hoist a polymorphic vectorised expression into a new top-level binding (representing a closure
--- function).
---
--- The hoisted expression is parameterised by (1) a set of type variables and (2) a set of value
--- variables that are passed as conventional type and value arguments.  The latter is implicitly
--- extended by the set of 'PA' dictionaries required for the type variables.
---
-hoistPolyVExpr :: [TyVar] -> [Var] -> Inline -> VM VExpr -> VM VExpr
-hoistPolyVExpr tvs vars inline p
-  = do { inline' <- addInlineArity inline . (+ length vars) <$> polyArity tvs
-       ; expr <- closedV . polyAbstract tvs $ \args ->
-                   mapVect (mkLams $ tvs ++ args ++ vars) <$> p
-       ; fn   <- hoistVExpr expr inline'
-       ; let varArgs = varsToCoreExprs vars
-       ; mapVect (\e -> e `mkApps` varArgs) <$> polyVApply (vVar fn) (mkTyVarTys tvs)
-       }
-
-takeHoisted :: VM [(Var, CoreExpr)]
-takeHoisted
-  = do
-      env <- readGEnv id
-      setGEnv $ env { global_bindings = [] }
-      return $ global_bindings env
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
deleted file mode 100644
index 4d32f5df74..0000000000
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ /dev/null
@@ -1,230 +0,0 @@
-module Vectorise.Utils.PADict (
-  paDictArgType,
-  paDictOfType,
-  paMethod,
-  prDictOfReprType,
-  prDictOfPReprInstTyCon
-) where
-
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Utils.Base
-
-import CoreSyn
-import CoreUtils
-import FamInstEnv
-import Coercion
-import Type
-import TyCoRep
-import TyCon
-import CoAxiom
-import Var
-import Outputable
-import DynFlags
-import FastString
-import Util
-import Control.Monad
-
-
--- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
--- just PA v. For (v :: (* -> *) -> *) it's
---
--- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a)
---
-paDictArgType :: TyVar -> VM (Maybe Type)
-paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv)
-  where
-    go ty (FunTy k1 k2)
-      = do
-          tv   <- if isCoercionType k1
-                  then newCoVar (fsLit "c") k1
-                  else newTyVar (fsLit "a") k1
-          mty1 <- go (mkTyVarTy tv) k1
-          case mty1 of
-            Just ty1 -> do
-                          mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2
-                          return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2
-            Nothing  -> go ty k2
-
-    go ty k
-      | isLiftedTypeKind k
-      = do
-          pa_cls <- builtin paClass
-          return $ Just $ mkClassPred pa_cls [ty]
-
-    go _ _ = return Nothing
-
-
--- |Get the PA dictionary for some type
---
-paDictOfType :: Type -> VM CoreExpr
-paDictOfType ty
-  = paDictOfTyApp ty_fn ty_args
-  where
-    (ty_fn, ty_args) = splitAppTys ty
-
-    paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
-    paDictOfTyApp ty_fn ty_args
-        | Just ty_fn' <- coreView ty_fn
-        = paDictOfTyApp ty_fn' ty_args
-
-    -- for type variables, look up the dfun and apply to the PA dictionaries
-    -- of the type arguments
-    paDictOfTyApp (TyVarTy tv) ty_args
-      = do
-        { dfun <- maybeCantVectoriseM "No PA dictionary for type variable"
-                                      (ppr tv <+> text "in" <+> ppr ty)
-                $ lookupTyVarPA tv
-        ; dicts <- mapM paDictOfType ty_args
-        ; return $ dfun `mkTyApps` ty_args `mkApps` dicts
-        }
-
-    -- for tycons, we also need to apply the dfun to the PR dictionary of
-    -- the representation type if the tycon is polymorphic
-    paDictOfTyApp (TyConApp tc []) ty_args
-      = do
-        { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty)
-                $ lookupTyConPA tc
-        ; super <- super_dict tc ty_args
-        ; dicts <- mapM paDictOfType ty_args
-        ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts
-        }
-      where
-        noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)"
-
-        super_dict _     []      = return []
-        super_dict tycon ty_args
-          = do
-            { pr <- prDictOfPReprInst (TyConApp tycon ty_args)
-            ; return [pr]
-            }
-
-    paDictOfTyApp _ _ = getDynFlags >>= failure
-
-    failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty)
-
--- |Produce code that refers to a method of the 'PA' class.
---
-paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr
-paMethod _ query ty
-  | Just tycon <- splitPrimTyCon ty             -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')?
-  = liftM Var $ builtin (query tycon)
-paMethod method _ ty
-  = do
-    { fn   <- builtin method
-    ; dict <- paDictOfType ty
-    ; return $ mkApps (Var fn) [Type ty, dict]
-    }
-
--- |Given a type @ty@, return the PR dictionary for @PRepr ty@.
---
-prDictOfPReprInst :: Type -> VM CoreExpr
-prDictOfPReprInst ty
-  = do
-    { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args })
-          <- preprFamInst ty
-    ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args
-    }
-
--- |Given a type @ty@, its PRepr synonym tycon and its type arguments,
--- return the PR @PRepr ty@. Suppose we have:
---
--- > type instance PRepr (T a1 ... an) = t
---
--- which is internally translated into
---
--- > type :R:PRepr a1 ... an = t
---
--- and the corresponding coercion. Then,
---
--- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un)
---
--- Note that @ty@ is only used for error messages
---
-prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr
-prDictOfPReprInstTyCon _ty prepr_ax prepr_args
-  = do
-      let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args []
-      dict <- prDictOfReprType' rhs
-      pr_co <- mkBuiltinCo prTyCon
-      let co = mkAppCo pr_co
-             $ mkSymCo
-             $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args []
-      return $ mkCast dict co
-
--- |Get the PR dictionary for a type. The argument must be a representation
--- type.
---
-prDictOfReprType :: Type -> VM CoreExpr
-prDictOfReprType ty
-  | Just (tycon, tyargs) <- splitTyConApp_maybe ty
-    = do
-        prepr <- builtin preprTyCon
-        if tycon == prepr
-          then do
-                 let [ty'] = tyargs
-                 pa <- paDictOfType ty'
-                 sel <- builtin paPRSel
-                 return $ Var sel `App` Type ty' `App` pa
-          else do
-                 -- a representation tycon must have a PR instance
-                 dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $
-                           lookupTyConPR tycon
-                 prDFunApply dfun tyargs
-
-  | otherwise
-    = do
-        -- it is a tyvar or an application of a tyvar
-        -- determine the PR dictionary from its PA dictionary
-        --
-        -- NOTE: This assumes that PRepr t ~ t is for all representation types
-        -- t
-        --
-        -- FIXME: This doesn't work for kinds other than * at the moment. We'd
-        -- have to simply abstract the term over the missing type arguments.
-        pa    <- paDictOfType ty
-        prsel <- builtin paPRSel
-        return $ Var prsel `mkApps` [Type ty, pa]
-
-prDictOfReprType' :: Type -> VM CoreExpr
-prDictOfReprType' ty = prDictOfReprType ty `orElseV`
-                       do dflags <- getDynFlags
-                          cantVectorise dflags "No PR dictionary for representation type"
-                                        (ppr ty)
-
--- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding
--- to the argument types.
-prDFunApply :: Var -> [Type] -> VM CoreExpr
-prDFunApply dfun tys
-  | Just [] <- ctxs    -- PR (a :-> b) doesn't have a context
-  = return $ Var dfun `mkTyApps` tys
-
-  | Just tycons <- ctxs
-  , tycons `equalLength` tys
-  = do
-      pa <- builtin paTyCon
-      pr <- builtin prTyCon
-      dflags <- getDynFlags
-      args <- zipWithM (dictionary dflags pa pr) tys tycons
-      return $ Var dfun `mkTyApps` tys `mkApps` args
-
-  | otherwise = do dflags <- getDynFlags
-                   invalid dflags
-  where
-    -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then
-    -- ctxs is Just [PA, PR]
-    ctxs = fmap (map fst)
-         $ sequence
-         $ map splitTyConApp_maybe
-         $ fst
-         $ splitFunTys
-         $ snd
-         $ splitForAllTys
-         $ varType dfun
-
-    dictionary dflags pa pr ty tycon
-      | tycon == pa = paDictOfType ty
-      | tycon == pr = prDictOfReprType ty
-      | otherwise   = invalid dflags
-
-    invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)
diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs
deleted file mode 100644
index d9f657f950..0000000000
--- a/compiler/vectorise/Vectorise/Utils/Poly.hs
+++ /dev/null
@@ -1,72 +0,0 @@
--- |Auxiliary functions to vectorise type abstractions.
-
-module Vectorise.Utils.Poly
-  ( polyAbstract
-  , polyApply
-  , polyVApply
-  , polyArity
-  )
-where
-
-import Vectorise.Vect
-import Vectorise.Monad
-import Vectorise.Utils.PADict
-import CoreSyn
-import Type
-import FastString
-import Control.Monad
-
-
--- Vectorisation of type arguments -------------------------------------------------------------
-
--- |Vectorise under the 'PA' dictionary variables corresponding to a set of type arguments.
---
--- The dictionary variables are new local variables that are entered into the local vectorisation
--- map.
---
--- The purpose of this function is to introduce the additional 'PA' dictionary arguments that are
--- needed when vectorising type abstractions.
---
-polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a
-polyAbstract tvs p
-  = localV
-  $ do { mdicts <- mapM mk_dict_var tvs
-       ; zipWithM_ (\tv -> maybe (defLocalTyVar tv)
-                                 (defLocalTyVarWithPA tv . Var)) tvs mdicts
-       ; p (mk_args mdicts)
-       }
-  where
-    mk_dict_var tv
-      = do { r <- paDictArgType tv
-           ; case r of
-               Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
-               Nothing -> return Nothing
-           }
-
-    mk_args mdicts = [dict | Just dict <- mdicts]
-
--- |Determine the number of 'PA' dictionary arguments required for a set of type variables (depends
--- on their kinds).
---
-polyArity :: [TyVar] -> VM Int
-polyArity tvs
-  = do { tys <- mapM paDictArgType tvs
-       ; return $ length [() | Just _ <- tys]
-       }
-
--- |Apply a expression to its type arguments as well as 'PA' dictionaries for these type arguments.
---
-polyApply :: CoreExpr -> [Type] -> VM CoreExpr
-polyApply expr tys
- = do { dicts <- mapM paDictOfType tys
-      ; return $ expr `mkTyApps` tys `mkApps` dicts
-      }
-
--- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for
--- these type arguments.
---
-polyVApply :: VExpr -> [Type] -> VM VExpr
-polyVApply expr tys
- = do { dicts <- mapM paDictOfType tys
-      ; return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
-      }
diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs
deleted file mode 100644
index 5cfc8415f7..0000000000
--- a/compiler/vectorise/Vectorise/Var.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-
--- |Vectorise variables and literals.
-
-module Vectorise.Var
-  ( vectBndr
-  , vectBndrNew
-  , vectBndrIn
-  , vectBndrNewIn
-  , vectBndrsIn
-  , vectVar
-  , vectConst
-  )
-where
-
-import Vectorise.Utils
-import Vectorise.Monad
-import Vectorise.Env
-import Vectorise.Vect
-import Vectorise.Type.Type
-import CoreSyn
-import Type
-import VarEnv
-import Id
-import FastString
-import Control.Applicative
-import Prelude -- avoid redundant import warning due to AMP
-
--- Binders ----------------------------------------------------------------------------------------
-
--- |Vectorise a binder variable, along with its attached type.
---
-vectBndr :: Var -> VM VVar
-vectBndr v
- = do (vty, lty) <- vectAndLiftType (idType v)
-      let vv = v `Id.setIdType` vty
-          lv = v `Id.setIdType` lty
-
-      updLEnv (mapTo vv lv)
-
-      return  (vv, lv)
-  where
-    mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) }
-
--- |Vectorise a binder variable, along with its attached type, but give the result a new name.
---
-vectBndrNew :: Var -> FastString -> VM VVar
-vectBndrNew v fs
- = do vty <- vectType (idType v)
-      vv  <- newLocalVVar fs vty
-      updLEnv (upd vv)
-      return vv
-  where
-    upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv }
-
--- |Vectorise a binder then run a computation with that binder in scope.
---
-vectBndrIn :: Var -> VM a -> VM (VVar, a)
-vectBndrIn v p
- = localV
- $ do vv <- vectBndr v
-      x <- p
-      return (vv, x)
-
--- |Vectorise a binder, give it a new name, then run a computation with that binder in scope.
---
-vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a)
-vectBndrNewIn v fs p
- = localV
- $ do vv <- vectBndrNew v fs
-      x  <- p
-      return (vv, x)
-
--- |Vectorise some binders, then run a computation with them in scope.
---
-vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a)
-vectBndrsIn vs p
- = localV
- $ do vvs <- mapM vectBndr vs
-      x   <- p
-      return (vvs, x)
-
-
--- Variables --------------------------------------------------------------------------------------
-
--- |Vectorise a variable, producing the vectorised and lifted versions.
---
-vectVar :: Var -> VM VExpr
-vectVar var
-  = do { vVar <- lookupVar var
-       ; case vVar of
-           Local (vv, lv) -> return (Var vv, Var lv) -- local variables have a vect & lifted version
-           Global vv      -> vectConst (Var vv)      -- global variables get replicated
-       }
-
-
--- Constants --------------------------------------------------------------------------------------
-
--- |Constants are lifted by replication along the integer context in the `VM` state for the number
--- of elements in the result array.
---
-vectConst :: CoreExpr -> VM VExpr
-vectConst c = (c,) <$> liftPD c
diff --git a/compiler/vectorise/Vectorise/Vect.hs b/compiler/vectorise/Vectorise/Vect.hs
deleted file mode 100644
index 03492291d6..0000000000
--- a/compiler/vectorise/Vectorise/Vect.hs
+++ /dev/null
@@ -1,126 +0,0 @@
--- |Simple vectorised constructors and projections.
---
-module Vectorise.Vect
-  ( Vect, VVar, VExpr, VBind
-
-  , vectorised
-  , lifted
-  , mapVect
-
-  , vVarType
-  , vNonRec
-  , vRec
-  , vVar
-  , vType
-  , vTick
-  , vLet
-  , vLams
-  , vVarApps
-  , vCaseDEFAULT
-  )
-where
-
-import CoreSyn
-import Type           ( Type )
-import Var
-
--- |Contains the vectorised and lifted versions of some thing.
---
-type Vect a = (a,a)
-type VVar   = Vect Var
-type VExpr  = Vect CoreExpr
-type VBind  = Vect CoreBind
-
--- |Get the vectorised version of a thing.
---
-vectorised :: Vect a -> a
-vectorised = fst
-
--- |Get the lifted version of a thing.
---
-lifted :: Vect a -> a
-lifted = snd
-
--- |Apply some function to both the vectorised and lifted versions of a thing.
---
-mapVect :: (a -> b) -> Vect a -> Vect b
-mapVect f (x, y) = (f x, f y)
-
--- |Combine vectorised and lifted versions of two things componentwise.
---
-zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c
-zipWithVect f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2)
-
--- |Get the type of a vectorised variable.
---
-vVarType :: VVar -> Type
-vVarType = varType . vectorised
-
--- |Wrap a vectorised variable as a vectorised expression.
---
-vVar :: VVar -> VExpr
-vVar = mapVect Var
-
--- |Wrap a vectorised type as a vectorised expression.
---
-vType :: Type -> VExpr
-vType ty = (Type ty, Type ty)
-
--- |Make a vectorised note.
---
-vTick :: Tickish Id -> VExpr -> VExpr
-vTick = mapVect . Tick
-
--- |Make a vectorised non-recursive binding.
---
-vNonRec :: VVar -> VExpr -> VBind
-vNonRec = zipWithVect NonRec
-
--- |Make a vectorised recursive binding.
---
-vRec :: [VVar] -> [VExpr] -> VBind
-vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les))
-  where
-    (vvs, lvs) = unzip vs
-    (ves, les) = unzip es
-
--- |Make a vectorised let expression.
---
-vLet :: VBind -> VExpr -> VExpr
-vLet = zipWithVect Let
-
--- |Make a vectorised lambda abstraction.
---
--- The lifted version also binds the lifting context 'lc'.
---
-vLams :: Var      -- ^ Var bound to the lifting context.
-      -> [VVar]   -- ^ Parameter vars for the abstraction.
-      -> VExpr    -- ^ Body of the abstraction.
-      -> VExpr
-vLams lc vs (ve, le)
-  = (mkLams vvs ve, mkLams (lc:lvs) le)
-  where
-    (vvs, lvs) = unzip vs
-
--- |Apply an expression to a set of argument variables.
---
--- The lifted version is also applied to the variable of the lifting context.
---
-vVarApps :: Var -> VExpr -> [VVar] -> VExpr
-vVarApps lc (ve, le) vvs
-  = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls))
-  where
-    (vs, ls) = unzip vvs
-
-
-vCaseDEFAULT :: VExpr  -- scrutinee
-             -> VVar   -- bnder
-             -> Type   -- type of vectorised version
-             -> Type   -- type of lifted version
-             -> VExpr  -- body of alternative.
-             -> VExpr
-vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody)
-  = (Case vscrut vbndr vty (mkDEFAULT vbody),
-     Case lscrut lbndr lty (mkDEFAULT lbody))
-  where
-    mkDEFAULT e = [(DEFAULT, [], e)]